module grid

character(len=512) :: output_file                 ! Name of output file (default: stdout)

character(len=32) :: grid_mode                    ! uniform, dipping_plane, cross_section
character(len=32) :: spacing_mode                 ! linear, exponential
character(len=32) :: coord_type                   ! cartesian, geographic

double precision :: x_beg
double precision :: x_end
double precision :: x_inc
integer :: nx
logical :: isXDefined

double precision :: y_beg
double precision :: y_end
double precision :: y_inc
integer :: ny
logical :: isYDefined

double precision :: z_beg
double precision :: z_end
double precision :: z_inc
integer :: nz
logical :: isZDefined

double precision :: x0                            ! x-coordinate of plane origin
double precision :: y0                            ! y-coordinate of plane origin
double precision :: z0                            ! z-coordinate of plane origin
double precision :: strike                        ! strike of plane
double precision :: dip                           ! dip of plane
double precision :: azimuth                       ! azimuth of plane

end module

!==================================================================================================!

program main
!----
! Generate Cartesian or geographic grids
!----

use io, only: stdout, stderr, verbosity
use trig, only: d2r
use geom, only: distaz2lola, lola2distaz
use earth, only: radius_earth_km

use grid, only: output_file, &
                grid_mode, &
                spacing_mode, &
                coord_type, &
                x_beg, &
                x_end, &
                x_inc, &
                nx, &
                isXDefined, &
                y_beg, &
                y_end, &
                y_inc, &
                ny, &
                isYDefined, &
                z_beg, &
                z_end, &
                z_inc, &
                nz, &
                isZDefined, &
                x0, &
                y0, &
                z0, &
                strike, &
                dip, &
                azimuth

implicit none

! Local variables
integer :: i, j, k, lu_out, ierr
double precision :: x, y, z, dx, dy, ddip, dist, angle, tand

! Parse command line
call gcmdln()
if (verbosity.eq.1) then
    write(stdout,'(A,A)')       ' output_file:  ',trim(output_file)
    write(stdout,'(A,A)')       ' grid_mode:    ',trim(grid_mode)
    write(stdout,'(A,A)')       ' spacing_mode: ',trim(spacing_mode)
    write(stdout,'(A,A)')       ' coord_type:   ',trim(coord_type)
    write(stdout,'(A,1PE14.6)') ' x_beg:        ',x_beg
    write(stdout,'(A,1PE14.6)') ' x_end:        ',x_end
    write(stdout,'(A,1PE14.6)') ' x_inc:        ',x_inc
    write(stdout,'(A,I14)')     ' nx:           ',nx
    write(stdout,'(A,L14)')     ' isXDefined:   ',isXDefined
    write(stdout,'(A,1PE14.6)') ' y_beg:        ',y_beg
    write(stdout,'(A,1PE14.6)') ' y_end:        ',y_end
    write(stdout,'(A,1PE14.6)') ' y_inc:        ',y_inc
    write(stdout,'(A,I14)')     ' ny:           ',ny
    write(stdout,'(A,L14)')     ' isYDefined:   ',isYDefined
    write(stdout,'(A,1PE14.6)') ' z_beg:        ',z_beg
    write(stdout,'(A,1PE14.6)') ' z_end:        ',z_end
    write(stdout,'(A,1PE14.6)') ' z_inc:        ',z_inc
    write(stdout,'(A,I14)')     ' nz:           ',nz
    write(stdout,'(A,L14)')     ' isZDefined:   ',isZDefined
    write(stdout,'(A,1PE14.6)') ' x0:           ',x0
    write(stdout,'(A,1PE14.6)') ' y0:           ',y0
    write(stdout,'(A,1PE14.6)') ' z0:           ',z0
    write(stdout,'(A,1PE14.6)') ' strike:       ',strike
    write(stdout,'(A,1PE14.6)') ' dip:          ',dip
    write(stdout,'(A,1PE14.6)') ' azimuth:      ',azimuth
    write(stdout,*)
endif

! Everything is hunky dory to start out
ierr = 0

! Determine the number of points and spacing between points in each dimension

! Calculate nx and dx for first dimension (x)
if (isXDefined) then
    call get_spacing(nx,x_inc,x_beg,x_end,spacing_mode,'x')
else
    call usage('grid: x values are required')
endif

! Calculate ny and dy for second dimension (y), if necessary
if (isYDefined) then
    call get_spacing(ny,y_inc,y_beg,y_end,spacing_mode,'y')
endif

! Calculate nz and dz for third dimension (z), if necessary
if (isZDefined.and.(grid_mode.eq.'uniform'.or.grid_mode.eq.'cross_section')) then
    call get_spacing(nz,z_inc,z_beg,z_end,spacing_mode,'z')
endif

! Where to send output?
if (output_file.eq.'stdout') then
    lu_out = stdout ! print to terminal
else
    lu_out = 33 ! write to file
    open(unit=lu_out,file=output_file,status='unknown')
endif

! Output depends on which dimensions have been specified and the grid mode

if (isXDefined.and..not.isYDefined.and..not.isZDefined) then

    ! Only x coordinate is defined

    if (grid_mode.eq.'uniform') then
        do i = 1,nx+1
            call get_value(x,i,x_inc,x_beg,spacing_mode,'x')
            write(lu_out,*) x
        enddo
    else
        ierr = 1
    endif

elseif (isXDefined.and.isYDefined.and..not.isZDefined) then

    ! X and y coordinates are defined

    if (grid_mode.eq.'uniform') then
        ! Print only x and y
        do i = 1,nx+1
            call get_value(x,i,x_inc,x_beg,spacing_mode,'x')
            do j = 1,ny+1
                call get_value(y,j,y_inc,y_beg,spacing_mode,'y')
                write(lu_out,*) x, y
            enddo
        enddo

    elseif (grid_mode.eq.'dipping_plane') then
        tand = dtan(dip*d2r)

        do i = 1,nx+1
            call get_value(x,i,x_inc,x_beg,spacing_mode,'x')
            do j = 1,ny+1
                call get_value(y,j,y_inc,y_beg,spacing_mode,'y')

                ! Calculate z on dipping plane
                if (coord_type.eq.'cartesian') then
                    dx = x-x0
                    dy = y-y0
                    angle = atan2(dx,dy)                 ! angle clockwise from +y axis
                    dist = sqrt(dx*dx+dy*dy)             ! distance from origin
                elseif (coord_type.eq.'geographic') then
                    call lola2distaz(x0,y0,x,y,dist,angle,'radians','radians',ierr)
                    if (ierr.ne.0) then
                        call usage('grid: error calculating dist and az')
                    endif
                    dist = dist*radius_earth_km
                    angle = angle
                endif

                ddip = dist*dsin(angle-strike*d2r)   ! horizontal, down-dip distance
                if (z0.lt.0.0d0) then
                    ! If input z0 is negative, interpret it as a depth with positive up
                    z = z0-ddip*tand
                else
                    ! If input z0 is positive or zero, interpret it as a depth with positive down
                    z = z0+ddip*tand
                endif

                write(lu_out,*) x, y, z
            enddo
        enddo
    else
        ierr = 1
    endif

elseif (isXDefined.and.isYDefined.and.isZDefined) then

    ! X, y, and z coordinates are defined

    if (grid_mode.eq.'uniform') then

        ! Print x, y, and z
        do i = 1,nx+1
            call get_value(x,i,x_inc,x_beg,spacing_mode,'x')
            do j = 1,ny+1
                call get_value(y,j,y_inc,y_beg,spacing_mode,'y')
                do k = 1,nz+1
                    call get_value(z,k,z_inc,z_beg,spacing_mode,'z')
                    write(lu_out,*) x, y, z
                enddo
            enddo
        enddo

    elseif (grid_mode.eq.'cross_section') then
        do i = 1,nx+1
            call get_value(dx,i,x_inc,x_beg,spacing_mode,'x') ! distance parallel to cross-section plane
            if (coord_type.eq.'cartesian') then
                x = x0 + dx*dsin(azimuth*d2r) ! move global x along plane
                y = y0 + dx*dcos(azimuth*d2r) ! move global y along plane
            elseif (coord_type.eq.'geographic') then
                call distaz2lola(x0,y0,dx/radius_earth_km,azimuth,x,y,'radians','degrees',ierr)
                if (ierr.ne.0) then
                    call usage('grid: error computing longitude and latitude')
                endif
            endif

            do j = 1,ny+1
                call get_value(dy,j,y_inc,y_beg,spacing_mode,'y') ! distance perpendicular to cross-section plane
                if (coord_type.eq.'cartesian') then
                    x = x + dy*dsin((azimuth-90.0d0)*d2r) ! add to global x
                    y = y + dy*dcos((azimuth-90.0d0)*d2r) ! add to global y
                elseif (coord_type.eq.'geographic') then
                    call distaz2lola(x,y,dy/radius_earth_km,azimuth-90.0d0,x,y,'radians','degrees',&
                                     ierr)
                    if (ierr.ne.0) then
                        call usage('grid: error computing longitude and latitude')
                    endif
                endif

                do k = 1,nz+1
                    call get_value(z,k,z_inc,z_beg,spacing_mode,'z')
                    write(lu_out,*) x, y, z, dx, dy
                enddo
            enddo
        enddo

    else
        ierr = 1
    endif

elseif (isXDefined.and..not.isYDefined.and.isZDefined) then

    ! X and z coordinates are defined

    if (grid_mode.eq.'cross_section') then

        dy = 0.0d0

        do i = 1,nx+1
            call get_value(dx,i,x_inc,x_beg,spacing_mode,'x')  ! distance parallel to cross-section plane
            if (coord_type.eq.'cartesian') then
                x = x0 + dx*dsin(azimuth*d2r) ! move global x along plane
                y = y0 + dx*dcos(azimuth*d2r) ! move global y along plane
            elseif (coord_type.eq.'geographic') then
                call distaz2lola(x0,y0,dx/radius_earth_km,azimuth,x,y,'radians','degrees',ierr)
                if (ierr.ne.0) then
                    call usage('grid: error computing longitude and latitude')
                endif
            endif

            do k = 1,nz+1
                call get_value(z,k,z_inc,z_beg,spacing_mode,'z')
                write(lu_out,*) x, y, z, dx, dy
            enddo
        enddo

    else
        ierr = 1
    endif

else
    write(stderr,'(A,L14)')     ' isXDefined:  ',isXDefined
    write(stderr,'(A,L14)')     ' isYDefined:  ',isYDefined
    write(stderr,'(A,L14)')     ' isZDefined:  ',isZDefined
    call usage('grid: WHOOPS! No output defined for this combination of inputs')
endif

if (ierr.eq.1) then
    write(stderr,*) 'grid: coordinate definitions and grid_mode are incompatible'
    write(stderr,*) 'grid_mode = uniform requires: x, x-y, or x-y-z'
    write(stderr,*) 'grid_mode = dipping_plane requires: x-y'
    write(stderr,*) 'grid_mode = cross_section requires: x-z or x-y-z'
    write(stderr,*) 'isXDefined:  ',isXDefined
    write(stderr,*) 'isYDefined:  ',isYDefined
    write(stderr,*) 'isZDefined:  ',isZDefined
    write(stderr,*) 'grid_mode:    "',trim(grid_mode),'"'
    call usage('exiting')
endif

if (output_file.ne.'stdout') then
    close(lu_out)
endif

end

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

subroutine get_spacing(n,d,beg,end,mode,dim)
!----
! Compute the number of grid points or spacing/ratio between grid points
!----

use io, only: stderr
implicit none

! Arguments
integer :: n
double precision :: d, beg, end
character(len=*) :: mode, dim

! Local variables
integer, parameter :: nmax = 1000000

! Verify that mode is available
if (mode.eq.'linear') then
    ! all good
elseif (mode.eq.'exponential') then
    ! all good
else
    call usage('get_spacing: no spacing mode named "'//trim(mode)//'"')
endif

! Verify that one of number and increment is defined
if (n.gt.0.and.abs(d).lt.1.0d19) then
    write(stderr,*) 'get_spacing: both number and increment are specified for ',trim(dim)
    call usage('no_details')
elseif (n.le.0.and.abs(d).gt.1.0d19) then
    write(stderr,*) 'get_spacing: neither number nor increment are specified for ',trim(dim)
    call usage('use -n'//trim(dim)//' or -d'//trim(dim))
endif

! If only first value is set, then make sure we only print it
if (dabs(end).gt.1.0d98) then
    if (n.gt.1.or.dabs(d).lt.1.0d20) then
        write(stderr,*) 'get_spacing: only first ',trim(dim),' value defined, setting n',trim(dim),' to 1'
    endif
    n = 1
    d = -1.0d20
endif

! Compute spacing from number of points or vice versa
if (n.gt.0) then

    ! input n is number of grid points, including starting and ending points
    ! subtract one to compute even spacing
    n = n - 1

    if (n.eq.0) then
        if (mode.eq.'linear') then
            d = 0.0d0
        elseif (mode.eq.'exponential') then
            d = 1.0d0
        endif
    else
        if (mode.eq.'linear') then
            ! difference, d, between points is the same
            d = (end-beg)/dble(n)
        elseif (mode.eq.'exponential') then
            ! ratio, d, between points is the same
            d = exp(log(end/beg)/dble(n))
        endif
    endif

elseif (dabs(d).lt.1.0d19) then

    ! Input d is the spacing between points (difference or ratio)

    if (mode.eq.'linear') then

        ! Check that end value will be reached
        if (abs(d).lt.1.0d-20) then
            ! Spacing between points is zero
            write(stderr,*) 'get_spacing: ',trim(dim),' increment cannot be ==0 in linear mode'
            call usage('no_details')

        elseif ((end-beg)*d.lt.0) then
            ! Increment has wrong sign to get from beg to end
            write(stderr,1001) trim(dim),d,beg,end
            call usage('no_details')

        endif

        n = int((end-beg)/d)

    elseif (mode.eq.'exponential') then

        ! Check that end value will be reached
        if (d-1.0d0.lt.1.0d-20) then
            ! Ratio between points is one
            write(stderr,*) 'get_spacing: ',trim(dim),' increment cannot be ==1 in exponential mode'
            call usage('no_details')

        elseif (d.le.0.0d0) then
            ! Ratio between points is zero or negative
            write(stderr,*) 'get_spacing: ',trim(dim),' increment cannot be <=0 in exponential mode'
            call usage('no_details')

        elseif (dabs(beg).lt.1.0d-20) then
            ! Starting value is zero
            write(stderr,*) 'get_spacing: starting ',trim(dim),' value cannot be ==0 in ',&
                            'exponential mode'
            call usage('no_details')

        elseif (log(end/beg)*log(d).lt.0) then
            ! Ratio has wrong magnitude to get from beg to end
            write(stderr,1002) trim(dim),d,beg,end
            call usage('no_details')

        endif

        n = int(log(end/beg)/log(d))

    endif
endif

! Be reasonable about number of grid points
if (n.gt.nmax) then
    write(stderr,1011) nmax,trim(dim)
    call usage('no_details')
endif

1001 format(' get_spacing: ',A1,' inc=',1PE10.2,' has wrong sign for bounds [',E10.2,',',E10.2,']')
1002 format(' get_spacing: ',A1,' inc=',1PE10.2,' has wrong magnitude for bounds [',&
            E10.2,',',E10.2,']')
1011 format(' get_spacing: you requested more than ',I10,X,A4,' points')

return
end subroutine

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

subroutine get_value(v,i,d,beg,mode,dim)
!----
! Compute the value of the ith grid point
!----

use io, only: stderr
implicit none

! Arguments
integer :: i
double precision :: v, d, beg
character(len=*) :: mode, dim

if (mode.eq.'linear') then
    v = beg + d*dble(i-1)
elseif (mode.eq.'exponential') then
    v = beg * d**dble(i-1)
else
    call usage('get_value: no spacing mode named "'//trim(mode)//'"')
endif

if (abs(v).gt.1.0d99) then
    write(stderr,*) 'get_value: computed a giant value in dimension ',dim
endif

return
end subroutine

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

subroutine gcmdln()

use io, only: stderr, verbosity, isNumeric

use grid, only: output_file, &
                grid_mode, &
                spacing_mode, &
                coord_type, &
                x_beg, &
                x_end, &
                x_inc, &
                nx, &
                isXDefined, &
                y_beg, &
                y_end, &
                y_inc, &
                ny, &
                isYDefined, &
                z_beg, &
                z_end, &
                z_inc, &
                nz, &
                isZDefined, &
                x0, &
                y0, &
                z0, &
                strike, &
                dip, &
                azimuth

implicit none

! Local variables
character(len=512) :: tag
integer :: i, j, narg, ios

! Initialize command line variables

! Output
output_file = 'stdout'

! Grid mode: uniform, dipping_plane, cross_section
grid_mode = 'uniform'

! Spacing mode: linear, exponential
spacing_mode = 'linear'

! Coordinate type: cartesian, geographic
coord_type = 'cartesian'

! Checks for output
isXDefined = .false.
isYDefined = .false.
isZDefined = .false.

! x parameters
x_beg = -1.0d99
x_end = -1.0d99
x_inc = -1.0d20
nx = -1

! y parameters
y_beg = -1.0d99
y_end = -1.0d99
y_inc = -1.0d20
ny = -1

! z parameters (uniform)
z_beg = -1.0d99
z_end = -1.0d99
z_inc = -1.0d20
nz = -1

! z parameters (dipping_plane, cross_section)
x0 = 0.0d0
y0 = 0.0d0
z0 = 0.0d0
strike = 0.0d0
dip = 0.0d0
azimuth = 0.0d0

narg = command_argument_count()
if (narg.eq.0) then
    call usage('')
endif

i = 1
do while (i.le.narg)

    call get_command_argument(i,tag)

    !---- X dimension
    if (trim(tag).eq.'-x') then
        ! First argument (starting x value) is required
        i = i + 1
        call get_command_argument(i,tag)
        if (.not.isNumeric(tag)) call usage('grid: x_beg is not numeric')
        read (tag,*) x_beg
        isXDefined = .true.
        ! Second argument (ending x value) is optional
        i = i + 1
        if (i.gt.narg) then
            ! No more arguments
            nx = 1
            cycle
        else
            call get_command_argument(i,tag)
            ! if (.not.isNumeric(tag)) call usage('grid: x_end is not numeric')
            read (tag,*,iostat=ios) x_end
            if (ios.ne.0) then
                ! No second value provided
                nx = 1
                i = i - 1
            endif
        endif

    elseif (trim(tag).eq.'-nx') then
        x_inc = -1.0d20 ! Overrides x-increment definition
        i = i + 1
        call get_command_argument(i,tag)
        read (tag,*) nx
    elseif (trim(tag).eq.'-dx') then
        nx = -1 ! Overrides nx definition
        i = i + 1
        call get_command_argument(i,tag)
        read (tag,*) x_inc

    !---- Y dimension
    elseif (trim(tag).eq.'-y') then
        ! First argument (starting y value) is required
        i = i + 1
        call get_command_argument(i,tag)
        read (tag,*) y_beg
        isYDefined = .true.
        ! Second argument (ending y value) is optional
        i = i + 1
        if (i.gt.narg) then
            ! No more arguments
            ny = 1
            cycle
        else
            call get_command_argument(i,tag)
            read (tag,*,iostat=ios) y_end
            if (ios.ne.0) then
                ! No second value provided
                ny = 1
                i = i - 1
            endif
        endif

    elseif (trim(tag).eq.'-ny') then
        y_inc = -1.0d20 ! Overrides y-increment definition
        i = i + 1
        call get_command_argument(i,tag)
        read (tag,*) ny
    elseif (trim(tag).eq.'-dy') then
        ny = -1 ! Overrides ny definition
        i = i + 1
        call get_command_argument(i,tag)
        read (tag,*) y_inc

    !---- Z dimension
    elseif (trim(tag).eq.'-z') then
        ! First argument (starting z value) is required
        i = i + 1
        call get_command_argument(i,tag)
        read (tag,*) z_beg
        isZDefined = .true.
        if (grid_mode.ne.'cross_section') then
            grid_mode = 'uniform'
        endif
        ! Second argument (ending z value) is optional
        i = i + 1
        if (i.gt.narg) then
            ! No more arguments
            nz = 1
            cycle
        else
            call get_command_argument(i,tag)
            read (tag,*,iostat=ios) z_end
            if (ios.ne.0) then
                ! No second value provided
                nz = 1
                i = i - 1
            endif
        endif

    elseif (trim(tag).eq.'-nz') then
        z_inc = -1.0d20 ! Overrides z-increment definition
        i = i + 1
        call get_command_argument(i,tag)
        read (tag,*) nz
    elseif (trim(tag).eq.'-dz') then
        nz = -1 ! Overrides nz definition
        i = i + 1
        call get_command_argument(i,tag)
        read (tag,*) z_inc

    elseif (trim(tag).eq.'-xsec') then
        ! Vertical plane
        ! x -> distance along azimuth
        ! y -> distance perpendicular to plane
        ! z -> depth
        grid_mode = 'cross_section'
        i = i + 1
        call get_command_argument(i,tag)
        read (tag,*) x0
        i = i + 1
        call get_command_argument(i,tag)
        read (tag,*) y0
        i = i + 1
        call get_command_argument(i,tag)
        read (tag,*) azimuth
    elseif (trim(tag).eq.'-xz') then
        write(stderr,*) 'grid: the -xz option is no longer needed, and is therefore deprecated'
        write(stderr,*) '-xsec prints all of the information'

    elseif (trim(tag).eq.'-dip') then
        ! Dipping plane
        grid_mode = 'dipping_plane'
        i = i + 1
        call get_command_argument(i,tag)
        read (tag,*) x0
        i = i + 1
        call get_command_argument(i,tag)
        read (tag,*) y0
        i = i + 1
        call get_command_argument(i,tag)
        read (tag,*) z0
        i = i + 1
        call get_command_argument(i,tag)
        read (tag,*) strike
        i = i + 1
        call get_command_argument(i,tag)
        read (tag,*) dip

    elseif (trim(tag).eq.'-geo') then
        coord_type = 'geographic'

    elseif (trim(tag).eq.'-exp') then
        spacing_mode = 'exponential'

    elseif (tag(1:2).eq.'-R') then
        ! Input x, y ranges in GMT limits format
        ! Remove "-R" from string
        j = index(tag,'-R')
        tag(j:j+1) = '  '
        ! Remove three "/" from string
        j = index(tag,'/')
        tag(j:j) = ' '
        j = index(tag,'/')
        tag(j:j) = ' '
        j = index(tag,'/')
        tag(j:j) = ' '
        read(tag,*) x_beg, x_end, y_beg, y_end
        isXDefined = .true.
        isYDefined = .true.

    elseif (trim(tag).eq.'-o') then
        i = i + 1
        call get_command_argument(i,output_file)

    elseif (trim(tag).eq.'-v'.or.trim(tag).eq.'verbosity') then
        i = i + 1
        call get_command_argument(i,tag)
        read(tag,*) verbosity

    else
        call usage('grid: no option '//tag)
    endif
    i = i + 1
enddo

return
end subroutine

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

subroutine usage(str)

use io, only: stderr

implicit none

! Arguments
character(len=*) :: str

! Local variables
integer :: i

if (str.ne.'') then
    i = index(str,'no_details')
    if (i.ne.0) then
        if (str.ne.'') then
            write(stderr,*) trim(str(1:i-1))
        endif
        call error_exit(1)
        write(stderr,*)
    endif
    write(stderr,*) trim(str)
    write(stderr,*)
endif

write(stderr,*) 'Usage: grid ...options...'
write(stderr,*)
write(stderr,*) '-o OFILE               Output to file (default prints to standard output)'
write(stderr,*) '-x XBEG [XEND]         Starting and (optional) ending x values'
write(stderr,*) '-nx NX                 Number of x points, including starting point'
write(stderr,*) '-dx DX                 Increment between x points'
write(stderr,*) '-y YBEG [YEND]         Starting and (optional) ending y values'
write(stderr,*) '-ny NY                 Number of y points, including starting point'
write(stderr,*) '-dy DY                 Increment between y points'
write(stderr,*) '-Rx1/x2/y1/y2          Define x, y limits with GMT limits format'
write(stderr,*) '-z ZBEG [ZEND]         Starting and (optional) ending z values'
write(stderr,*) '-nz NZ                 Number of z points, including starting point'
write(stderr,*) '-dz DZ                 Increment between z points'
write(stderr,*) '-dip X0 Y0 Z0 STR DIP  Z-values lie on plane containing (X0,Y0,Z0) with STR/DIP'
write(stderr,*) '-xsec X0 Y0 AZ         Vertical cross section through (X0,Y0) with strike AZ ',&
                                        '(x=az; y=az+90; z=up)'
write(stderr,*) '-geo                   Treat -dip and -xsec coordinates as lon/lat'
write(stderr,*) '-exp                   Make grid increment exponential'
write(stderr,*)
write(stderr,*) 'See man page for details'
write(stderr,*)

call error_exit(1)
end subroutine


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! z_upr1utri_decompress
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! This routine decompresses a unitary plus rank one upper-triangular
! matrix (upr1utri). Such a matrix is stored as a product
! of two sequences of Givens' rotations and a complex unimodular
! diagonal matrix.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! INPUT VARIABLES:
!
!  DIAG            CHARACTER
!                    .TRUE.: diagonals only
!                    .FALSE.: entire triangular part
!
!  N               INTEGER
!                    dimension of matrix
!
!  D               REAL(8) array of dimension (2*N)
!                    array of generators for complex diagonal matrix
!
!  C               REAL(8) array of dimension (3*N)
!                    array of generators for first sequence of rotations
!
!  B               REAL(8) array of dimension (3*N)
!                    array of generators for third sequence of rotations
!
! OUTPUT VARIABLES:
!
!  T               COMPLEX(8) array of dimension (N,N)
!                    if DIAG == .TRUE. diagonal of T stored in first column
!                    if DIAG == .FALSE. entire triangular part is constructed
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine z_upr1utri_decompress(DIAG,N,D,C,B,T)

  implicit none

  ! input variables
  logical, intent(in) :: DIAG
  integer, intent(in) :: N
  real(8), intent(in) :: D(2*N), C(3*N), B(3*N)
  complex(8), intent(inout) :: T(N,N)

  ! compute variables
  integer :: ii,ind
  complex(8) :: g, p, temp(2,2)

  ! diagonals only
  if (DIAG) then

    ! initialize T
    T(:,1) = cmplx(0d0,0d0,kind=8)

    ! compute diagonals
    do ii = 1,N
      T(ii,1) = -cmplx(D(2*ii-1),D(2*ii),kind=8)*B(3*ii)/C(3*ii)
    end do

  ! entire upper-triangular part
  else

    ! initialize T
    T = cmplx(0d0,0d0,kind=8)
    do ii=1,N
      T(ii,ii) = cmplx(1d0,0d0,kind=8)
    end do

    ! fill with B
    do ii=1,(N-1)
      ind = 3*(ii-1)
      temp(1,1) = cmplx(B(ind+1),B(ind+2),kind=8)
      temp(2,1) = cmplx(B(ind+3),0d0,kind=8)
      temp(1,2) = -temp(2,1)
      temp(2,2) = conjg(temp(1,1))
      T(1:(ii+1),ii:(ii+1)) = matmul(T(1:(ii+1),ii:(ii+1)),temp)
    end do
    T(:,N) = T(:,N)*cmplx(B(3*(N-1)+1),B(3*(N-1)+2),kind=8)

    ! update first row
    g = cmplx(1d0,0d0,kind=8)
    p = g
    do ii=1,(N-1)
      ind = 3*(ii-1)
      T(1,ii) = T(1,ii)-(g*cmplx(B(ind+1),B(ind+2),kind=8)+&
                cmplx(C(ind+1),-C(ind+2),kind=8)*B(ind+3)/C(ind+3))/p
      p = p*C(ind+3)
      g = cmplx(B(ind+1),-B(ind+2),kind=8)*cmplx(C(ind+1),-C(ind+2),kind=8)-&
          g*B(ind+3)*C(ind+3)
    end do
    ind = 3*(N-1)
    T(1,N) = T(1,N)-(g*cmplx(B(ind+1),B(ind+2),kind=8)+&
             cmplx(C(ind+1),-C(ind+2),kind=8)*B(ind+3)/C(ind+3))/p

    ! apply C
    do ii=1,(N-1)
      ind = 3*(ii-1)
      temp(1,1) = cmplx(C(ind+1),C(ind+2),kind=8)
      temp(2,1) = cmplx(C(ind+3),0d0,kind=8)
      temp(1,2) = -temp(2,1)
      temp(2,2) = conjg(temp(1,1))
      T(ii:(ii+1),(ii+1):N) = matmul(temp,T(ii:(ii+1),(ii+1):N))
      T(ii,ii) = temp(1,1)*T(ii,ii) + temp(1,2)*T(ii+1,ii)
      T(ii+1,ii) = cmplx(0d0,0d0,kind=8)
    end do
    T(N,N) = T(N,N)*cmplx(C(3*(N-1)+1),C(3*(N-1)+2),kind=8) + &
             cmplx(B(3*(N-1)+3),0d0,kind=8)*cmplx(-C(3*(N-1)+3),0d0,kind=8)

    ! apply D
    do ii=1,N
      ind = 2*(ii-1)
      T(ii,:) = T(ii,:)*cmplx(D(ind+1),D(ind+2),kind=8)
    end do

  end if

end subroutine z_upr1utri_decompress


!
!  Copyright 2017-2020 SALMON developers
!
!  Licensed under the Apache License, Version 2.0 (the "License");
!  you may not use this file except in compliance with the License.
!  You may obtain a copy of the License at
!
!      http://www.apache.org/licenses/LICENSE-2.0
!
!  Unless required by applicable law or agreed to in writing, software
!  distributed under the License is distributed on an "AS IS" BASIS,
!  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
!  See the License for the specific language governing permissions and
!  limitations under the License.
!
!-----------------------------------------------------------------------------------------
module salmon_math
  implicit none

  public :: erf_salmon, &
            erfc_salmon, &
            bessel_j1_salmon, &
            matrix_inverse, &
            xjl, dxjl

  interface matrix_inverse
     module procedure matrix_inverse_double
     module procedure matrix_inverse_complex
  end interface
contains
!--------------------------------------------------------------------------------
!! Error function and its complement are implemented based on the reference
!! W. J. Cody, Math. Comp. 23 631 (1969)
  function erf_salmon(x) result(y)
    !$acc routine seq
    implicit none
    real(8),intent(in) :: x
    real(8) :: y
    real(8) :: xa

    xa = abs(x)
    if(xa < 0.46875d0)then
       y = sign( erf_salmon_short(xa) , x )
    else if(xa < 4d0)then
       y = erfc_salmon_mid(xa)
       y = sign(1d0 - y,x)
    else
       y = erfc_salmon_long(xa)
       y = sign(1d0 - y,x)
    end if

  end function erf_salmon
!--------------------------------------------------------------------------------
  function erfc_salmon(x) result(y)
    !$acc routine seq
    implicit none
    real(8),intent(in) :: x
    real(8) :: y
    real(8) :: xa

    xa = abs(x)
    if(xa < 0.46875d0)then
       y = 1d0 - erf_salmon(xa)
    else if(xa < 4d0)then
       y = erfc_salmon_mid(xa)
    else
       y = erfc_salmon_long(xa)
    end if

    if(x<0d0) y = 2d0 - y

  end function erfc_salmon
!--------------------------------------------------------------------------------
  function erf_salmon_short(x) result(y) ! 0d0 <=x<0.5d0
    !$acc routine seq
    implicit none
    real(8),intent(in) :: x
    real(8) :: y
    real(8) :: x2
    real(8),parameter :: &
       a(0:4) = (/  &
       & 3.209377589138469472562d3, &
       & 3.774852376853020208137d2, &
       & 1.138641541510501556495d2, &
       & 3.161123743870565596947d0, &
       & 1.857777061846031526730d-1 &
       &/), &
       b(0:4) = (/  &
       & 2.844236833439170622273d3, &
       & 1.282616526077372275645d3, &
       & 2.440246379344441733056d2, &
       & 2.360129095234412093499d1, &
       & 1d0 &
       &/)

    x2 = x**2
    y = x*(a(0) + a(1)*x2 + a(2)*x2**2 + a(3)*x2**3 + a(4)*x2**4 ) &
         /(b(0) + b(1)*x2 + b(2)*x2**2 + b(3)*x2**3 + b(4)*x2**4 )

  end function erf_salmon_short
!--------------------------------------------------------------------------------
  function erfc_salmon_mid(x) result(y) ! 0.46875d0 <x< 4d0
    !$acc routine seq
    implicit none
    real(8),intent(in) :: x
    real(8) :: y
    real(8) :: x2
    real(8),parameter :: &
       p(0:7) = (/  &
       & 3.004592610201616005d2, &
       & 4.519189537118729422d2, &
       & 3.393208167343436870d2, &
       & 1.529892850469404039d2, &
       & 4.316222722205673530d1, &
       & 7.211758250883093659d0, &
       & 5.641955174789739711d-1, &
       &-1.368648573827167067d-7 &
       &/), &
       q(0:7) = (/ &
       & 3.004592609569832933d2, &
       & 7.909509253278980272d2, &
       & 9.313540948506096211d2, &
       & 6.389802644656311665d2, &
       & 2.775854447439876434d2, &
       & 7.700015293522947295d1, &
       & 1.278272731962942351d1, &
       & 1d0 &
       &/)

    x2 = x**2

    y = (p(0) + p(1)*x + p(2)*x**2 + p(3)*x**3 + p(4)*x**4 &
         + p(5)*x**5 + p(6)*x**6 + p(7)*x**7)/ &
         (q(0) + q(1)*x + q(2)*x**2 + q(3)*x**3 + q(4)*x**4 &
         + q(5)*x**5 + q(6)*x**6 + q(7)*x**7)
    y = exp(-x2)*y

  end function erfc_salmon_mid
!--------------------------------------------------------------------------------
  function erfc_salmon_long(x) result(y) ! 4d0 <x
    !$acc routine seq
    use math_constants, only : pi
    implicit none
    real(8),intent(in) :: x
    real(8) :: y
    real(8) :: x2,x2_i
    real(8),parameter :: &
       r(0:4) = (/ &
       & -2.99610707703542174d-3, &
       & -4.94730910623250734d-2, &
       & -2.26956593539686930d-1, &
       & -2.78661308609647788d-1, &
       & -2.23192459734184686d-2  &
       &/), &
       s(0:4) = (/ &
       & 1.06209230528467918d-2, &
       & 1.91308926107829841d-1, &
       & 1.05167510706793207d0,  &
       & 1.98733201817135256d0,  &
       & 1d0 &
       &/)

    x2 = x**2

    x2_i = 1d0/x2
    y = 1d0/sqrt(pi) &
         +x2_i*(r(0) + r(1)*x2_i + r(2)*x2_i**2 + r(3)*x2_i**3 + r(4)*x2_i**4) &
         /(s(0) + s(1)*x2_i + s(2)*x2_i**2 + s(3)*x2_i**3 + s(4)*x2_i**4)
    y = exp(-x2)/x*y

  end function erfc_salmon_long

!--------------------------------------------------------------------------------
  !! 1st order Bessel function
  ! The algorithm and numerical table are implemented based on the reference:
  ! Methods and Programs for Mathematical Functions, Prentice-Hall, 1989
  real(8) function bessel_j1_salmon(x) result(y)
    implicit none
    real(8), intent(in) :: x
    real(8), parameter :: &
      &  rp(0:3) = (/ &
      & -8.999712d+08, +4.522283d+11, -7.274942d+13, +3.682957d+15  &
      & /), &
      & rq(0:8) = (/ &
      & +1.000000d+00, +6.208365d+02, +2.569873d+05, +8.351468d+07,  &
      & +2.215116d+10, +4.749141d+12, +7.843696d+14, +8.952223d+16,  &
      & +5.322786d+18 /), &
      & pp(0:6) = (/ &
      & +7.621256d-04, +7.313971d-02, +1.127196d+00, +5.112080d+00,  &
      & +8.424046d+00, +5.214516d+00, +1.000000d+00 /), &
      & pq(0:6) = (/ &
      & +5.713231d-04, +6.884559d-02, +1.105142d+00, +5.073864d+00,  &
      & +8.399856d+00, +5.209828d+00, +1.000000d+00 /), &
      & qp(0:7) = (/ &
      & +5.108626d-02, +4.982139d+00, +7.582383d+01, +3.667796d+02,  &
      & +7.108563d+02, +5.974896d+02, +2.116888d+02, +2.520702d+01  &
      & /), &
      & qq(0:7) = (/ &
      & +1.000000d+00, +7.423733d+01, +1.056449d+03, +4.986411d+03,  &
      & +9.562319d+03, +7.997042d+03, +2.826193d+03, +3.360936d+02  &
      & /)
    real(8), parameter :: z1 = +1.468197d+01
    real(8), parameter :: z2 = +4.921846d+01
    real(8), parameter :: thpio4 =  +2.356194d+00
    real(8), parameter :: sq2opi =  +7.978846d-01
    real(8) :: w, z, p, q, xn
    real(8) :: rpz, rqz, ppz, pqz, qpz, qqz

    if (x < 0) then
      w = -x
    else
      w = +x
    end if

    if( w <= 5.0 ) then
      z = x * x
      rpz = ((rp(0)*z+rp(1))*z+rp(2))*z+rp(3)
      rqz = (((((((rq(0)*z+rq(1))*z+rq(2))*z+rq(3))*z+rq(4))*z &
        & +rq(5))*z+rq(6))*z+rq(7))*z+rq(8)
      w = rpz / rqz
      w = w * x * (z - z1) * (z - z2)
      y = w
      return
    end if

    w = 5.0 / x
    z = w * w
    ppz = (((((pp(0)*z+pp(1))*z+pp(2))*z+pp(3))*z+pp(4))*z+pp(5))*z+pp(6)
    pqz = (((((pq(0)*z+pq(1))*z+pq(2))*z+pq(3))*z+pq(4))*z+pq(5))*z+pq(6)
    qpz = ((((((qp(0)*z+qp(1))*z+qp(2))*z+qp(3))*z &
    & +qp(4))*z+qp(5))*z+qp(6))*z+qp(7)
    qqz = ((((((qq(0)*z+qq(1))*z+qq(2))*z+qq(3))*z &
    & +qq(4))*z+qq(5))*z+qq(6))*z+qq(7)
    p = ppz/pqz
    q = qpz/qqz
    xn = x - thpio4
    p = p * cos(xn) - w * q * sin(xn)
    y = p * sq2opi / sqrt(x)
    return
  end function bessel_j1_salmon
!--------------------------------------------------------------------------------
  subroutine matrix_inverse_double(rmat)
    implicit none
    real(8),intent(inout) :: rmat(:,:)
    integer :: nn
! for lapack
    integer :: lwork, info
    integer, allocatable :: ipiv(:) ! dimension N
    real(8), allocatable :: work(:) ! dimension LWORK

    nn = size(rmat,dim=1)
    lwork = nn * max(nn, 64)

    allocate(ipiv(nn),work(lwork))

    call dgetrf(nn, nn, rmat, nn, ipiv, info)  ! factorize
    call dgetri(nn, rmat, nn, ipiv, work, lwork, info)  ! inverse

    deallocate(ipiv,work)

  end subroutine matrix_inverse_double
!--------------------------------------------------------------------------------
  subroutine matrix_inverse_complex(zmat)
    implicit none
    complex(8),intent(inout) :: zmat(:,:)
    integer :: nn
! for lapack
    integer :: lwork, info
    integer, allocatable :: ipiv(:) ! dimension N
    complex(8), allocatable :: zwork(:) ! dimension LWORK

    nn = size(zmat,dim=1)
    lwork = nn * max(nn, 64)

    allocate(ipiv(nn),zwork(lwork))

    call zgetrf(nn, nn, zmat, nn, ipiv, info)  ! factorize
    call zgetri(nn, zmat, nn, ipiv, zwork, lwork, info)  ! inverse

    deallocate(ipiv,zwork)

  end subroutine matrix_inverse_complex
!--------10--------20--------30--------40--------50--------60--------70--------80--------90--------100-------110-------120-------130
  real(8) function xjl(x,l) result(r_xjl)
    implicit none
!argument
    integer,intent(in) :: l
    real(8),intent(in) :: x
!local variable
    real(8),parameter :: eps=1.0d-1

    if (l >= 5) then
      write(*,*) 'xjl function not prepared for l>=5'
      stop
    endif

    if (x < eps) then
      select case(l)
      case(-1)
         r_xjl = 1.d0 - x**2/2.d0 + x**4/24.d0
      case(0)
         r_xjl = x - x**3/6.d0 + x**5/120.d0 -x**7/5040.d0 + x**9/362880.d0
      case(1)
         r_xjl = (2.d0/6.d0)*x**2 - (2.d0/60.d0)*x**4 + (1.d0/840.d0)*x**6 - (2.d0/90720.d0)*x**8
      case(2)
         r_xjl = (4.d0/60.d0)*x**3 - (4.d0/840.d0)*x**5 + (2.d0/15120.d0)*x**7 - (2.d0/997920.d0)*x**9
      case(3)
         r_xjl = (8.d0/840.d0)*x**4 - (8.d0/15120.d0)*x**6 + (4.d0/332640.d0)*x**8
      case(4)
         r_xjl = (16.d0/15120.d0)*x**5 - (16.d0/332640.d0)*x**7 + (8.d0/8648640.d0)*x**9
      end select
    else
      select case(l)
      case(-1)
         r_xjl = cos(x)
      case(0)
         r_xjl = sin(x)
      case(1)
         r_xjl = (1.d0/x)*sin(x) - cos(x)
      case(2)
         r_xjl = (3.d0/x**2 - 1.d0)*sin(x) - (3.d0/x)*cos(x)
      case(3)
         r_xjl = (15.d0/x**3 - 6.d0/x)*sin(x) - (15.d0/x**2 - 1.d0)*cos(x)
      case(4)
         r_xjl = (105.d0/x**4 - 45.d0/x**2 + 1.d0)*sin(x) - (105.d0/x**3 - 10.d0/x)*cos(x)
      end select
    end if

    return
  end function xjl
!--------10--------20--------30--------40--------50--------60--------70--------80--------90--------100-------110-------120-------130
  real(8) function dxjl(x,l) result(r_dxjl)
    implicit none
!argument
    integer,intent(in) :: l
    real(8),intent(in) :: x
!local variable
    real(8),parameter :: eps=1.0d-1

    if (l >= 5) then
      write(*,*) 'dxjl function not prepared for l>=5'
      stop
    endif

    if (x < eps) then
      select case(l)
      case(-1)
         r_dxjl = x - x**3/6.d0
      case(0)
         r_dxjl = 1.d0 - x**2/2.d0 + x**4/24.d0 - x**6/720.d0 + x**8/40320.d0
      case(1)
         r_dxjl = (2.d0/3.d0)*x**1 - (2.d0/15.d0)*x**3 + (1.d0/140.d0)*x**5 - (2.d0/11340.d0)*x**7
      case(2)
         r_dxjl = (4.d0/20.d0)*x**2 - (4.d0/168.d0)*x**4 + (2.d0/2160.d0)*x**6 - (2.d0/110880.d0)*x**7
      case(3)
         r_dxjl = (8.d0/210.d0)*x**3 - (8.d0/2520.d0)*x**5 + (4.d0/41580.d0)*x**7
      case(4)
         r_dxjl = (16.d0/3024.d0)*x**4 - (16.d0/47520.d0)*x**6 + (8.d0/960960.d0)*x**8
      end select
    else
      select case(l)
      case(-1)
         r_dxjl = -sin(x)
      case(0)
         r_dxjl = cos(x)
      case(1)
         r_dxjl = -(1.d0/x**2 - 1.d0)*sin(x) + (1.d0/x)*cos(x)
      case(2)
         r_dxjl = -(6.d0/x**3 - 3.d0/x)*sin(x) + (6.d0/x**2 - 1.d0)*cos(x)
      case(3)
         r_dxjl = -(45.d0/x**4 - 21.d0/x**2 + 1.d0)*sin(x) + (45.d0/x**3 - 6.d0/x)*cos(x)
      case(4)
         r_dxjl = -(420.d0/x**5 - 195.d0/x**3 + 10.d0/x)*sin(x) + (420.d0/x**4 - 55.d0/x**2 + 1.d0)*cos(x)
      end select
    end if

    return
  end function dxjl

!--------10--------20--------30--------40--------50--------60--------70--------80--------90--------100-------110-------120-------130
! This function Ylm is related to the real spherical harmonics Ylm0 by
! Ylm=sqrt(4*pi/(2l+1))*r**l*Ylm0 and is a monomial of x,y,z
  Function Ylm(x,y,z,il,im)
    implicit none
    real(8),intent(IN) :: x,y,z
    integer,intent(IN) :: il,im
    integer :: ilm
    real(8) :: Ylm,r2

    ilm=il*il+il+1+im
    r2=x*x+y*y+z*z
    select case( ilm )
    case(1)  ; Ylm=1.d0                                     ! ilm=1  (0  0)
    case(2)  ; Ylm=-y                                       ! ilm=2  (1 -1)
    case(3)  ; Ylm=z                                        ! ilm=3  (1  0)
    case(4)  ; Ylm=-x                                       ! ilm=4  (1  1)
    case(5)  ; Ylm=sqrt(3.d0)*x*y                           ! ilm=5  (2 -2)
    case(6)  ; Ylm=-sqrt(3.d0)*y*z                          ! ilm=6  (2 -1)
    case(7)  ; Ylm=(3.d0*z*z-r2)/2.d0                       ! ilm=7  (2  0)
    case(8)  ; Ylm=-sqrt(3.d0)*x*z                          ! ilm=8  (2  1)
    case(9)  ; Ylm=sqrt(3.d0/4.d0)*(x*x-y*y)                ! ilm=9  (2  2)
    case(10) ; Ylm=-sqrt(5.d0/8.d0)*y*(3*x*x-y*y)           ! ilm=10 (3 -3)
    case(11) ; Ylm=sqrt(15.d0)*x*y*z                        ! ilm=11 (3 -2)
    case(12) ; Ylm=-sqrt(3.d0/8.d0)*y*(5.d0*z*z-r2)         ! ilm=12 (3 -1)
    case(13) ; Ylm=z*(5.d0*z*z-3*r2)/2.d0                   ! ilm=13 (3  0)
    case(14) ; Ylm=-sqrt(3.d0/8.d0)*x*(5.d0*z*z-r2)         ! ilm=14 (3  1)
    case(15) ; Ylm=sqrt(15.d0/4.d0)*z*(x*x-y*y)             ! ilm=15 (3  2)
    case(16) ; Ylm=-sqrt(5.d0/8.d0)*x*(x*x-3.d0*y*y)        ! ilm=16 (3  3)
    case(17) ; Ylm=sqrt(35.d0)/2.d0*x*y*(x*x-y*y)           ! ilm=17 (4 -4)
    case(18) ; Ylm=-sqrt(35.d0/8.d0)*y*z*(3.d0*x*x-y*y)     ! ilm=18 (4 -3)
    case(19) ; Ylm=sqrt(5.d0)/2.d0*x*y*(7.d0*z*z-r2)        ! ilm=19 (4 -2)
    case(20) ; Ylm=-sqrt(5.d0/8.d0)*y*z*(7.d0*z*z-3.d0*r2)  ! ilm=20 (4 -1)
    case(21) ; Ylm=(35.d0*z**4-30.d0*z*z*r2+3.d0*r2*r2)/8.d0! ilm=21 (4  0)
    case(22) ; Ylm=-sqrt(5.d0/8.d0)*x*z*(7.d0*z**2-3.d0*r2) ! ilm=22 (4  1)
    case(23) ; Ylm=sqrt(5.d0)/4.d0*(7.d0*z*z-r2)*(x*x-y*y)  ! ilm=23 (4  2)
    case(24) ; Ylm=-sqrt(35.d0/8.d0)*x*z*(x*x-3.d0*y*y)     ! ilm=24 (4  3)
    case(25) ; Ylm=sqrt(35.d0)/8.d0*(x**4+y**4-6.d0*x*x*y*y)! ilm=25 (4  4)
    end select

    return
  End Function Ylm
!--------10--------20--------30--------40--------50--------60--------70--------80--------90--------100-------110-------120-------130
  Function dYlm(x,y,z,il,im,idir)
    implicit none
    real(8),intent(IN) :: x,y,z
    integer,intent(IN) :: il,im,idir
    integer :: ilm
    real(8) :: dYlm

    ilm=il*il+il+1+im
    if ((ilm > 16) .or. (il >= 4)) then
      write(*,*) 'dYlm routine not prepared for il>=4'
      stop
    endif
    if((ilm ==  1 ).and.(idir == 1)) dYlm=0.d0                            ! ilm=1  (0  0)
    if((ilm ==  1 ).and.(idir == 2)) dYlm=0.d0                            ! ilm=1  (0  0)
    if((ilm ==  1 ).and.(idir == 3)) dYlm=0.d0                            ! ilm=1  (0  0)
    if((ilm ==  2 ).and.(idir == 1)) dYlm=0.d0                            ! ilm=2  (1 -1)
    if((ilm ==  2 ).and.(idir == 2)) dYlm=-1.d0                           ! ilm=2  (1 -1)
    if((ilm ==  2 ).and.(idir == 3)) dYlm=0.d0                            ! ilm=2  (1 -1)
    if((ilm ==  3 ).and.(idir == 1)) dYlm=0.d0                            ! ilm=3  (1  0)
    if((ilm ==  3 ).and.(idir == 2)) dYlm=0.d0                            ! ilm=3  (1  0)
    if((ilm ==  3 ).and.(idir == 3)) dYlm=1.d0                            ! ilm=3  (1  0)
    if((ilm ==  4 ).and.(idir == 1)) dYlm=-1.d0                           ! ilm=4  (1  1)
    if((ilm ==  4 ).and.(idir == 2)) dYlm=0.d0                            ! ilm=4  (1  1)
    if((ilm ==  4 ).and.(idir == 3)) dYlm=0.d0                            ! ilm=4  (1  1)
    if((ilm ==  5 ).and.(idir == 1)) dYlm=sqrt(3.d0)*y                    ! ilm=5  (2 -2)
    if((ilm ==  5 ).and.(idir == 2)) dYlm=sqrt(3.d0)*x                    ! ilm=5  (2 -2)
    if((ilm ==  5 ).and.(idir == 3)) dYlm=0.d0                            ! ilm=5  (2 -2)
    if((ilm ==  6 ).and.(idir == 1)) dYlm=0.d0                            ! ilm=6  (2 -1)
    if((ilm ==  6 ).and.(idir == 2)) dYlm=-sqrt(3.d0)*z                   ! ilm=6  (2 -1)
    if((ilm ==  6 ).and.(idir == 3)) dYlm=-sqrt(3.d0)*y                   ! ilm=6  (2 -1)
    if((ilm ==  7 ).and.(idir == 1)) dYlm=-x                              ! ilm=7  (2  0)
    if((ilm ==  7 ).and.(idir == 2)) dYlm=-y                              ! ilm=7  (2  0)
    if((ilm ==  7 ).and.(idir == 3)) dYlm=2.d0*z                          ! ilm=7  (2  0)
    if((ilm ==  8 ).and.(idir == 1)) dYlm=-sqrt(3.d0)*z                   ! ilm=8  (2  1)
    if((ilm ==  8 ).and.(idir == 2)) dYlm=0.d0                            ! ilm=8  (2  1)
    if((ilm ==  8 ).and.(idir == 3)) dYlm=-sqrt(3.d0)*x                   ! ilm=8  (2  1)
    if((ilm ==  9 ).and.(idir == 1)) dYlm=sqrt(3.d0)*x                    ! ilm=9  (2  2)
    if((ilm ==  9 ).and.(idir == 2)) dYlm=-sqrt(3.d0)*y                   ! ilm=9  (2  2)
    if((ilm ==  9 ).and.(idir == 3)) dYlm=0.d0                            ! ilm=9  (2  2)
    if((ilm == 10 ).and.(idir == 1)) dYlm=-3.d0*sqrt(5.d0/2.d0)*x*y                         ! ilm=10 (3 -3)
    if((ilm == 10 ).and.(idir == 2)) dYlm=-3.d0/2.d0*sqrt(5.d0/2.d0)*(x*x-y*y)               ! ilm=10 (3 -3)
    if((ilm == 10 ).and.(idir == 3)) dYlm=0.d0                                              ! ilm=10 (3 -3)
    if((ilm == 11 ).and.(idir == 1)) dYlm=sqrt(15.d0)*y*z                                   ! ilm=11 (3 -2)
    if((ilm == 11 ).and.(idir == 2)) dYlm=sqrt(15.d0)*z*x                                   ! ilm=11 (3 -2)
    if((ilm == 11 ).and.(idir == 3)) dYlm=sqrt(15.d0)*x*y                                   ! ilm=11 (3 -2)
    if((ilm == 12 ).and.(idir == 1)) dYlm=sqrt(3.d0/2.d0)*x*y                               ! ilm=12 (3 -1)
    if((ilm == 12 ).and.(idir == 2)) dYlm=-1.d0/2.d0*sqrt(3.d0/2.d0)*(4.d0*z*z-x*x-3.d0*y*y)! ilm=12 (3 -1)
    if((ilm == 12 ).and.(idir == 3)) dYlm=-4.d0*sqrt(3.d0/2.d0)*y*z                         ! ilm=12 (3 -1)
    if((ilm == 13 ).and.(idir == 1)) dYlm=-3.d0*z*x                                         ! ilm=13 (3  0)
    if((ilm == 13 ).and.(idir == 2)) dYlm=-3.d0*y*z                                         ! ilm=13 (3  0)
    if((ilm == 13 ).and.(idir == 3)) dYlm=3.d0/2.d0*(2.d0*z*z-x*x-y*y)                      ! ilm=13 (3  0)
    if((ilm == 14 ).and.(idir == 1)) dYlm=-1.d0/2.d0*sqrt(3.d0/2.d0)*(4.d0*z*z-3.d0*x*x-y*y)! ilm=14 (3  1)
    if((ilm == 14 ).and.(idir == 2)) dYlm=sqrt(3.d0/2.d0)*x*y                               ! ilm=14 (3  1)
    if((ilm == 14 ).and.(idir == 3)) dYlm=-4.d0*sqrt(3.d0/2.d0)*z*x                         ! ilm=14 (3  1)
    if((ilm == 15 ).and.(idir == 1)) dYlm=sqrt(15.d0)*z*x                                   ! ilm=15 (3  2)
    if((ilm == 15 ).and.(idir == 2)) dYlm=-sqrt(15.d0)*y*z                                  ! ilm=15 (3  2)
    if((ilm == 15 ).and.(idir == 3)) dYlm=1.d0/2.d0*sqrt(15.d0)*(x*x-y*y)                   ! ilm=15 (3  2)
    if((ilm == 16 ).and.(idir == 1)) dYlm=-3.d0/2.d0*sqrt(5.d0/2.d0)*(x*x-y*y)              ! ilm=16 (3  3)
    if((ilm == 16 ).and.(idir == 2)) dYlm=3.d0*sqrt(5.d0/2.d0)*x*y                          ! ilm=16 (3  3)
    if((ilm == 16 ).and.(idir == 3)) dYlm=0.d0                                              ! ilm=16 (3  3)

    return
  End Function dYlm

!--------10--------20--------30--------40--------50--------60--------70--------80--------90--------100-------110-------120-------130

  subroutine spline(Np,xn,yn,an,bn,cn,dn)
    implicit none
    integer,intent(in) :: Np
    real(8),intent(in) :: xn(0:Np-1),yn(0:Np-1)
    real(8),intent(out) :: an(0:Np-2),bn(0:Np-2),cn(0:Np-2),dn(0:Np-2)
    integer :: i,Npm2,info
    real(8) :: dxn(0:Np-1),dyn(0:Np-1),u(1:Np-2),v(1:Np-2),Amat(1:Np-2,1:Np-2)
    real(8) :: Amat_t(1:Np-2,1:Np-2)
  ! for lapack
    integer :: LWORK
    integer, allocatable :: IPIV(:) ! dimension N
    real(8), allocatable :: WORK(:) ! dimension LWORK
  ! for check inverse matrix problem
  !  integer :: j,k
  !  real(8) :: Amat_chk(1:Np-2,1:Np-2)
  !  real(8) :: ss

    Npm2 = Np-2
    LWORK = Npm2*Npm2*6
    allocate(IPIV(Npm2),WORK(LWORK))

    do i = 0,Np-2
      dxn(i) = xn(i+1) - xn(i)
      dyn(i) = yn(i+1) - yn(i)
    end do

    do i = 1,Npm2
      v(i) = 6d0*(dyn(i)/dxn(i) - dyn(i-1)/dxn(i-1))
    end do

    Amat = 0d0
    Amat(1,1) = 2d0*(dxn(1) + dxn(0))
    Amat(1,2) = dxn(1)
    do i = 2,Npm2-1
      Amat(i,i+1) = dxn(i)
      Amat(i,i  ) = 2d0*(dxn(i)+dxn(i-1))
      Amat(i,i-1) = dxn(i-1)
    end do
    Amat(Npm2,Npm2  ) = 2d0*(dxn(Npm2)+dxn(Npm2-1))
    Amat(Npm2,Npm2-1) = dxn(Npm2-1)

  ! inverse matrix problem
    Amat_t = Amat

    call DGETRF(Npm2, Npm2, Amat_t, Npm2, IPIV, info)  ! factorize
    call DGETRI(Npm2, Amat_t, Npm2, IPIV, WORK, LWORK, info)  ! inverse

  !  check inverse matrix problem
  !  do i = 1,Npm2
  !    do j = 1,Npm2
  !      ss = 0d0
  !      do k = 1,Npm2
  !        ss = ss + Amat(i,k)*Amat_t(k,j)
  !      end do
  !      Amat_chk(i,j) = ss
  !    end do
  !  end do
  !
  !  do i = 1,Npm2
  !    write(*,'(999e16.6e3)')(Amat_chk(i,j),j=1,Npm2)
  !  end do
  !
  !  stop

    do i = 1,Npm2
      u(i) = sum(Amat_t(i,:)*v(:))
    end do

  ! for b
    bn(0) = 0d0
    bn(1:Np-2) = 0.5d0*u(1:Np-2)
  ! for a
    do i = 0,Npm2-1
      an(i) = (u(i+1) -2d0*bn(i))/(6d0*dxn(i))
    end do
    an(Npm2) = (0d0 -2d0*bn(Npm2))/(6d0*dxn(Npm2))
  ! for d
    dn(0:Npm2) = yn(0:Npm2)
  ! for c
    i=0
    cn(i) = dyn(i)/dxn(i) - dxn(i)*(u(i+1)+2d0*0.d0)/6d0
    do i = 1,Npm2-1
       cn(i) = dyn(i)/dxn(i) - dxn(i)*(u(i+1)+2d0*u(i))/6d0
    end do
    cn(Npm2) = dyn(Npm2)/dxn(Npm2) - dxn(Npm2)*(0d0+2d0*u(Npm2))/6d0

    return
  end subroutine spline
!--------10--------20--------30--------40--------50--------60--------70--------80--------90--------100-------110-------120-------130

end module salmon_math
!--------------------------------------------------------------------------------


      program riemann
      implicit none

c..solves the exact riemann problem
c..original code from bruce fryxell

c..declare
      integer    n,npts,itmax,iter,i
      parameter (n = 1000)
      real       x(n),rho(n),u(n),p(n),
     1           rhol,pl,ul,rhor,pr,ur,gamma,xi,t,xl,xr,
     2           rho1,p1,u1,rho5,p5,u5,p40,p41,f0,f,eps,
     3           f1,p4,error,z,c5,gm1,gp1,gmfac1,gmfac2,fact,
     4           u4,rho4,w,p3,u3,rho3,c1,c3,xsh,xcd,xft,xhd,dx

c..define initial conditions
c..state at left of discontinuity
         rhol = 10.0
         pl   = 100.0
         ul   = 0.

c..state at right of discontinuity
         rhor = 1.0
         pr   = 1.0
         ur   = 0.

         if (ul .ne. 0. .or. ur .ne. 0.) then
          write (6,*) 'must have ul = ur = 0.'
          stop
         endif

c.. equation of state
         gamma = 1.4

c..location of discontinuity at t = 0
         xi = 2.0

c..time at which solution is desired
         t = 0.40

c..number of points in solution
         npts = 500
         if (npts .gt. n) then
          write (6,*) 'number of points exceeds array size'
          stop
         endif

c..spatial interval over which to compute solution
         xl = 0.0
         xr = 5.0
         if (xr .lt. xl) then
          write (6,*) 'xr must be greater than xl'
          stop
         endif

c..begin solution
      if (pl .gt. pr) then
         rho1 = rhol
         p1   = pl
         u1   = ul
         rho5 = rhor
         p5   = pr
         u5   = ur
      else
         rho1 = rhor
         p1   = pr
         u1   = ur
         rho5 = rhol
         p5   = pl
         u5   = ul
      endif

c..solve for post-shock pressure by secant method
c..initial guesses

         p40 = p1
         p41 = p5
         f0  = f(p40, p1, p5, rho1, rho5, gamma)

c..maximum number of iterations and maxium allowable relative error
         itmax = 20
         eps   = 1.e-5

         do iter = 1, itmax
          f1 = f(p41, p1, p5, rho1, rho5, gamma)
          if (f1 .eq. f0) go to 10

          p4 = p41 - (p41 - p40) * f1 / (f1 - f0)

          error = abs (p4 - p41) / p41
          if (error .lt. eps) go to 10

          p40 = p41
          p41 = p4
          f0  = f1
         enddo
         write (6,*) 'iteration failed to converge'
         stop 'abnormal termination'

10       continue

c..compute post-shock density and velocity
         z  = (p4 / p5 - 1.)
         c5 = sqrt (gamma * p5 / rho5)

         gm1 = gamma - 1.
         gp1 = gamma + 1.
         gmfac1 = 0.5 * gm1 / gamma
         gmfac2 = 0.5 * gp1 / gamma

         fact = sqrt (1. + gmfac2 * z)

         u4 = c5 * z / (gamma * fact)
         rho4 = rho5 * (1. + gmfac2 * z)
     1               / (1. + gmfac1 * z)

c..shock speed
         w = c5 * fact

c..compute values at foot of rarefaction
         p3 = p4
         u3 = u4
         rho3 = rho1 * (p3 / p1)**(1. /gamma)

c..compute positions of waves
      if (pl .gt. pr) then
       c1 = sqrt (gamma * p1 / rho1)
       c3 = sqrt (gamma * p3 / rho3)

       xsh = xi + w * t
       xcd = xi + u3 * t
       xft = xi + (u3 - c3) * t
       xhd = xi - c1 * t

c..and do say what we found
       write (6, 500)
       write (6, 501) rho1, p1, u1
       write (6, 502)
       write (6, 503) rho3, p3, u3
       write (6, 504) rho4, p4, u4
       write (6, 505) rho5, p5, u5

       write (6, 506) xhd
       write (6, 507) xft
       write (6, 508) xcd
       write (6, 509) xsh

500    format (// 2x, 'Region', 4x, 'Density', 8x, 'Pressure',
     1                          8x, 'Velocity')
501    format (5x, '1', 3(2x,1pe14.7))
502    format (5x, '2' ,20x, 'RAREFACTION')
503    format (5x, '3', 3(2x,1pe14.7))
504    format (5x, '4', 3(2x,1pe14.7))
505    format (5x, '5', 3(2x,1pe14.7)//)

506    format (2x, 'Head Of Rarefaction    x = ', 1pe14.7)
507    format (2x, 'Foot Of Rarefaction    x = ', 1pe14.7)
508    format (2x, 'Contact Discontinuity  x = ', 1pe14.7)
509    format (2x, 'Shock                  x = ', 1pe14.7//)

c..compute solution as a function of position
       dx = (xr - xl) / (npts - 1)
       do i = 1, npts
        x(i) = xl + dx * (i - 1)
       enddo

       do i = 1, npts
        if (x(i) .lt. xhd) then
         rho(i) = rho1
         p(i)   = p1
         u(i)   = u1
        else if (x(i) .lt. xft) then
         u(i)   = 2. / gp1 * (c1 + (x(i) - xi) / t)
         fact   = 1. - 0.5 * gm1 * u(i) / c1
         rho(i) = rho1 * fact ** (2. / gm1)
         p(i)   = p1 * fact ** (2. * gamma / gm1)
        else if (x(i) .lt. xcd) then
         rho(i) = rho3
         p(i)   = p3
         u(i)   = u3
        else if (x(i) .lt. xsh) then
         rho(i) = rho4
         p(i)   = p4
         u(i)   = u4
        else
         rho(i) = rho5
         p(i)   = p5
         u(i)   = u5
        endif
       enddo
      endif

c..if pr > pl, reverse solution
      if (pr .gt. pl) then
       c1 = sqrt (gamma * p1 / rho1)
       c3 = sqrt (gamma * p3 / rho3)

       xsh = xi - w * t
       xcd = xi - u3 * t
       xft = xi - (u3 - c3) * t
       xhd = xi + c1 * t

c..and do say what we found
       write (6, 500)
       write (6, 501) rho5, p5, u5
       write (6, 602) rho4, p4, u4
       write (6, 503) rho3, p3, u3
       write (6, 604)
       write (6, 505) rho1, p1, u1

       write (6, 609) xsh
       write (6, 508) xcd
       write (6, 507) xft
       write (6, 606) xhd

602    format (5x, '2', 3(2x,1pe14.7))
604    format (5x, '4' ,20x, 'RAREFACTION')
606    format (2x, 'Head Of Rarefaction    x = ', 1pe14.7//)
609    format (2x, 'Shock                  x = ', 1pe14.7)

       dx = (xr - xl) / (npts - 1)
       do i = 1, npts
         x(i) = xl + dx * (i - 1)
       enddo

       do i = 1, npts
        if (x(i) .lt. xsh) then
           rho(i) = rho5
           p(i)   = p5
           u(i)   = -u5
        else if (x(i) .lt. xcd) then
           rho(i) = rho4
           p(i)   = p4
           u(i)   = -u4
        else if (x(i) .lt. xft) then
           rho(i) = rho3
           p(i)   = p3
           u(i)   = -u3
        else if (x(i) .lt. xhd) then
           u(i)   = -2. / gp1 * (c1 + (xi - x(i)) / t)
           fact   = 1. + 0.5 * gm1 * u(i) / c1
           rho(i) = rho1 * fact ** (2. / gm1)
           p(i)   = p1 * fact ** (2. * gamma / gm1)
        else
           rho(i) = rho1
           p(i)   = p1
           u(i)   = -u1
        endif
       enddo
      endif

      open (unit=1, file = 'output',status='unknown')
      write (1, 1000)
1000  format (2x, 'i', 10x, 'x', 12x, 'density', 8x, 'pressure',
     1             8x, 'velocity'/)
1001  format (i4, 4(2x, 1pe14.7))
      do i = 1, npts
       write (1,1001) i, x(i), rho(i), p(i), u(i)
      enddo
      close (1)
      stop 'normal termination'
      end

      real function f(p4, p1, p5, rho1, rho5, gamma)
      implicit none

c..shock tube equation

c..declare the pass
      real p4,p1,p5,rho1,rho5,gamma

c..local variables
      real z,c1,c5,gm1,gp1,g2,fact

      z = (p4 / p5 - 1.)
      c1 = sqrt (gamma * p1 / rho1)
      c5 = sqrt (gamma * p5 / rho5)

      gm1 = gamma - 1.
      gp1 = gamma + 1.
      g2  = 2. * gamma

      fact = gm1 / g2 * (c5 / c1) * z
     1     / sqrt (1. + gp1 / g2 * z)
      fact = (1. - fact) ** (g2 / gm1)

      f = p1 * fact - p4

      return
      end


*DECK C9LGMC
      COMPLEX FUNCTION C9LGMC (ZIN)
C***BEGIN PROLOGUE  C9LGMC
C***SUBSIDIARY
C***PURPOSE  Compute the log gamma correction factor so that
C            LOG(CGAMMA(Z)) = 0.5*LOG(2.*PI) + (Z-0.5)*LOG(Z) - Z
C            + C9LGMC(Z).
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C7A
C***TYPE      COMPLEX (R9LGMC-S, D9LGMC-D, C9LGMC-C)
C***KEYWORDS  COMPLETE GAMMA FUNCTION, CORRECTION TERM, FNLIB,
C             LOG GAMMA, LOGARITHM, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C Compute the LOG GAMMA correction term for large ABS(Z) when REAL(Z)
C .GE. 0.0 and for large ABS(AIMAG(Y)) when REAL(Z) .LT. 0.0.  We find
C C9LGMC so that
C   LOG(Z) = 0.5*LOG(2.*PI) + (Z-0.5)*LOG(Z) - Z + C9LGMC(Z)
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   780401  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   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   900720  Routine changed from user-callable to subsidiary.  (WRB)
C***END PROLOGUE  C9LGMC
      COMPLEX ZIN, Z, Z2INV
      DIMENSION BERN(11)
      LOGICAL FIRST
      SAVE BERN, NTERM, BOUND, XBIG, XMAX, FIRST
      DATA BERN( 1) /    .08333333333 3333333E0   /
      DATA BERN( 2) /   -.002777777777 7777778E0  /
      DATA BERN( 3) /    .0007936507936 5079365E0 /
      DATA BERN( 4) /   -.0005952380952 3809524E0 /
      DATA BERN( 5) /    .0008417508417 5084175E0 /
      DATA BERN( 6) /   -.001917526917 5269175E0  /
      DATA BERN( 7) /    .006410256410 2564103E0  /
      DATA BERN( 8) /   -.02955065359 4771242E0   /
      DATA BERN( 9) /    .1796443723 6883057E0    /
      DATA BERN(10) /  -1.392432216 9059011E0     /
      DATA BERN(11) /  13.40286404 4168392E0      /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  C9LGMC
      IF (FIRST) THEN
         NTERM = -0.30*LOG(R1MACH(3))
         BOUND = 0.1170*NTERM*(0.1*R1MACH(3))**(-1./(2*NTERM-1))
         XBIG = 1.0/SQRT(R1MACH(3))
         XMAX = EXP (MIN(LOG(R1MACH(2)/12.0), -LOG(12.*R1MACH(1))) )
      ENDIF
      FIRST = .FALSE.
C
      Z = ZIN
      X = REAL (Z)
      Y = AIMAG(Z)
      CABSZ = ABS(Z)
C
      IF (X .LT. 0.0 .AND. ABS(Y) .LT. BOUND) CALL XERMSG ('SLATEC',
     +   'C9LGMC', 'NOT VALID FOR NEGATIVE REAL(Z) AND SMALL ' //
     +   'ABS(AIMAG(Z))', 2, 2)
      IF (CABSZ .LT. BOUND) CALL XERMSG ('SLATEC', 'C9LGMC',
     +   'NOT VALID FOR SMALL ABS(Z)', 3, 2)
C
      IF (CABSZ.GE.XMAX) GO TO 50
C
      IF (CABSZ.GE.XBIG) C9LGMC = 1.0/(12.0*Z)
      IF (CABSZ.GE.XBIG) RETURN
C
      Z2INV = 1.0/Z**2
      C9LGMC = (0.0, 0.0)
      DO 40 I=1,NTERM
        NDX = NTERM + 1 - I
        C9LGMC = BERN(NDX) + C9LGMC*Z2INV
 40   CONTINUE
C
      C9LGMC = C9LGMC/Z
      RETURN
C
 50   C9LGMC = (0.0, 0.0)
      CALL XERMSG ('SLATEC', 'C9LGMC', 'Z SO BIG C9LGMC UNDERFLOWS', 1,
     +   1)
      RETURN
C
      END


!==========================================================================
elemental function gsw_sa_freezing_estimate (p, saturation_fraction, ct, t)
!==========================================================================
!
! Form an estimate of SA from a polynomial in CT and p
!
!--------------------------------------------------------------------------

use gsw_mod_teos10_constants, only : gsw_sso

use gsw_mod_toolbox, only : gsw_ct_from_t

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: p, saturation_fraction
real (r8), intent(in), optional :: ct, t

real (r8) :: gsw_sa_freezing_estimate

real (r8) :: ctx, ctsat, sa

! note that aa = 0.502500117621d0/35.16504
real (r8), parameter :: aa = 0.014289763856964_r8
real (r8), parameter :: bb = 0.057000649899720_r8

real (r8), parameter :: p0  =  2.570124672768757e-1_r8
real (r8), parameter :: p1  = -1.917742353032266e1_r8
real (r8), parameter :: p2  = -1.413382858617969e-2_r8
real (r8), parameter :: p3  = -5.427484830917552e-1_r8
real (r8), parameter :: p4  = -4.126621135193472e-4_r8
real (r8), parameter :: p5  = -4.176407833276121e-7_r8
real (r8), parameter :: p6  =  4.688217641883641e-5_r8
real (r8), parameter :: p7  = -3.039808885885726e-8_r8
real (r8), parameter :: p8  = -4.990118091261456e-11_r8
real (r8), parameter :: p9  = -9.733920711119464e-9_r8
real (r8), parameter :: p10 = -7.723324202726337e-12_r8
real (r8), parameter :: p11 =  7.121854166249257e-16_r8
real (r8), parameter :: p12 =  1.256474634100811e-12_r8
real (r8), parameter :: p13 =  2.105103897918125e-15_r8
real (r8), parameter :: p14 =  8.663811778227171e-19_r8

! A very rough estimate of sa to get the saturated ct
if (present(ct)) then
    sa = max(-(ct + 9e-4_r8*p)/0.06_r8, 0.0_r8)
    ctx = ct
else if (present(t)) then
    sa = max(-(t + 9e-4_r8*p)/0.06_r8, 0.0_r8)
    ctx = gsw_ct_from_t(sa,t,p)
else
    gsw_sa_freezing_estimate = 0.0_r8
    return
end if

! CTsat is the estimated value of CT if the seawater were saturated with
! dissolved air, recognizing that it actually has the air fraction
! saturation_fraction; see McDougall, Barker and Feistel, 2014).

ctsat = ctx - (1.0_r8-saturation_fraction)* &
        (1e-3_r8)*(2.4_r8-aa*sa)*(1.0_r8+bb*(1.0_r8-sa/gsw_sso))

gsw_sa_freezing_estimate = p0 &
        + p*(p2 + p4*ctsat + p*(p5 + ctsat*(p7 + p9*ctsat) &
        + p*(p8  + ctsat*(p10 + p12*ctsat) + p*(p11 + p13*ctsat + p14*p)))) &
        + ctsat*(p1 + ctsat*(p3 + p6*p))

return
end function

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


program partition
implicit none

!---------------------------------------
! calculate the rate constant
! for the reaction D + H2 -> DH + H:
!---------------------------------------

integer, parameter :: dp = SELECTED_REAL_KIND(15)
integer :: i !counter

!------------
! constants:
!------------

real(dp), parameter :: boltzmann = 1.380648813D-23 ![m^(2)kg/(s^(2)K)]
real(dp), parameter :: h = 6.626069573D-34 ![m^(2)kg/s]
real(dp), parameter :: pi = 3.141592654
real(dp), parameter :: c = 299792458  !speed of light - [m/s]
real(dp), parameter :: Ea = 9.7 ![kcal/mol]
real(dp), parameter :: kcaltoJ = 4184 !conversion factor
real(dp), parameter :: angstrom = 1D-10 !convert angstroms to meters
real(dp), parameter :: mp = 1.672621777D-27 !mass of proton - [kg]
real(dp), parameter :: mn = 1.674927351D-27 !mass of neutron - [kg]
real(dp), parameter :: me = 9.10938291D-31 !mass of electron - [kg]
real(dp), parameter :: symm = 2 !statistical factor.
real(dp), parameter :: R = 8.314462175 !gas constant [J/(Kmol)]
real(dp), parameter :: N = 6.0221412927D+23!avogadro's number - [mole^(-1)]

!--------------
! variables:
!--------------

real, parameter :: V = 1 !volume -> [m^3]
real(dp) :: E, vim, elec !Energy to cross the
                           !barrier and imaginary frequency
                           !and electronic partition function
real(dp), dimension(701) :: k, Q, T, trans, vib, rot! rate constant,
                                 !temperature and partition functions
                                 !for the reaction
real(dp), parameter :: eD = 2, eH2 = 1, eDHH = 2 !electronic partition
                                                   !functions
real(dp), dimension(701) :: dG, dH, dS, KC, wigner, kcorr
                                 !Gibbs free energy, enthalpy and
                                 !entropy of the transition state
                                 !reaction, the equilibrium constant and
                                 !the wigner correction.

! Deuterium:
real(dp) :: mD !mass of deuterium
real(dp), dimension(701) :: qtrans !translational partition function of
                                       !deuterium.

! Hydrogen molecule:
real(dp), dimension(701) :: vibH2, rotH2, transH2
                     !translational, rotational and vibrational partition
                     !function of hydrogen
real(dp) :: f !vibrational frequency [s^(-1)].
real(dp) :: mH, mH2, rH2 !mass of hydrogen atom, mass and
                              !radius of hydrogen molecule
real(dp) :: IH2 ! angular momentum
real(dp) :: ZPEH2 !ZP correction

! D-H-H:
real(dp), dimension(701) :: DHHrot, DHHvib, DHHtrans, QDHH
real(dp) :: IDHH, rDHH, mDHH !rotational momentum, distances and
                                 !mass for the transition state
real(dp) :: vDHH1, vDHH2 !vibrational frequencies, ali toa vtoroto
                              !moze da bide greska
real(dp) :: ZPEDHH !zero point correction

!----------------------------------------
! define some values first:
!----------------------------------------

vim = (850.)*c *(100.) !imaginary frequency of the
                              !transition state [s^(-1)]
elec = eDHH/(eH2*eD) !electronic partition f-tion.
mD = mp + mn + me ![kg] - mass of deuterium
f = (4401.) * c * (100.)
mH = mp + me !mass of hydrogen [kg]
mH2 = (2.)*(mp + me) !mass of hydrogen molecule [kg]
rH2 = 0.741*angstrom !distance between hydrogen atoms - [m]
IH2 = ((mH*mH)/(mH+mH))*(rH2**(2.)) !moment of inertia of hydrogen molecule
ZPEH2 = (h*f*N)/(2.)

! moment of inertia and mass of transition state:
rDHH = 0.929*angstrom
IDHH = mD*(rDHH**(2.)) + mH*(rDHH**(2.)) - ((mD*rDHH-mH*rDHH)**(2.))/(mD+mH+mH)
mDHH = mD + mH + mH
vDHH1 = (1780.)*c*(100.)
vDHH2 = (861.)*c*(100.)
ZPEDHH = Ea*kcaltoJ + N*(0.5)*(h*vDHH1 + (2.)*h*vDHH2)

E = (ZPEDHH-ZPEH2)

open (unit=1, file='results_D2.txt', status='new', action='write')
write(1,*) 'T', '	', 'k', '	', 'Kc', '	', 'G', '	', 'H', '	', 'S',&
   '	', 'wigner', '	', 'kcorr'

!----------------------------------
! calculate partition function:
!----------------------------------

do i = 1, 701
   T(i) = i + 299

   !----------------------------------------------------------Deuterium:
   !--------------------------------------------------------------------

   qtrans(i) = ((((2.)*pi*mD*boltzmann*T(i))**(3./2.))/(h**(3.)))*V

   !--------------------------------------------------Hydrogen molecule:
   !--------------------------------------------------------------------

   vibH2(i) = (1.) / ((1.) - exp(-h*f/(boltzmann*T(i))))
   rotH2(i) = ((8.)*(pi**(2.))*IH2*boltzmann*T(i))/h !In the presentation
   !(8.)*(pi**(2.))*IH2*boltzmann*T(i) is under aroot
   !but everywhere else I looked, it wasn't, so
   !I used that formula.

   transH2(i) = (((2.)*pi*mH2*boltzmann*T(i))**(3./2.))/(h**(3.))*V

   !--------------------------------------------------------------D-H-H:
   !--------------------------------------------------------------------

   DHHrot(i) = ((8.)*(pi**(2.))*IDHH*boltzmann*T(i))/h
   DHHvib(i) = ((1.) / ((1.) - exp(-h*vDHH2/(boltzmann*T(i))))**(2.))*&
   ((1.) / ((1.) - exp(-h*vDHH1/(boltzmann*T(i)))))
   DHHtrans(i) = (((2.)*pi*mDHH*boltzmann*T(i))**(.3/.2))/(h**(3.))*V

   !---------------------------------------------------------value of k:
   !--------------------------------------------------------------------

   rot(i) = DHHrot(i)/rotH2(i)
   trans(i) = DHHtrans(i)/(qtrans(i)*transH2(i))
   vib(i) = DHHvib(i)/vibH2(i)
   Q(i) = rot(i)*vib(i)*trans(i)*elec
   KC(i) = Q(i)*N*(1000.)*exp(-(E/(R*T(i)))) !L/mol
   k(i) = symm*((boltzmann*T(i))/h)*Q(i)*exp(-(E/(R*T(i))))*N*1000
                                          !k(i) -> [L/mols]
   dG(i) = -R*T(i)*LOG(KC(i))
   dH(i) = E - (2.)*R*T(i)
   dS(i) = (dH(i)-dG(i))/T(i)
   wigner(i) = (1.) + ((1./24.))*((h*vim)/(boltzmann*T(i)))**(2.)
   kcorr(i) = k(i)*wigner(i)

   write(1,*) T(i), k(i), Kc(i), dG(i), dH(i), dS(i), wigner(i), kcorr(i)
end do

end program partition


	subroutine geoutm(rlon,rlat,rx,ry,UTM_PROJECTION_ZONE,iway)

c   Convert geodetic longitude and latitude to UTM, and back.
c   Use iway=ILONGLAT2UTM for long/lat to UTM, IUTM2LONGLAT for UTM to lat/long.

        implicit real*8(a-h,o-z)

c   CAMx v2.03
c
c     UTM_GEO performs UTM to geodetic (long/lat) translation, and back.
c
c     This is a Fortran version of the BASIC program "Transverse Mercator
c     Conversion", Copyright 1986, Norman J. Berls (Stefan Musarra, 2/94)
c     Based on algorithm taken from "Map Projections Used by the USGS"
c     by John P. Snyder, Geological Survey Bulletin 1532, USDI.
c
c     Input/Output arguments:
c
c        rlon                  Longitude (deg, negative for West)
c        rlat                  Latitude (deg)
c        rx                    UTM easting (m)
c        ry                    UTM northing (m)
c        UTM_PROJECTION_ZONE   UTM zone
c        iway                  Conversion type
c                              ILONGLAT2UTM=geodetic to UTM
c                              IUTM2LONGLAT=UTM to geodetic

	integer UTM_PROJECTION_ZONE,iway

	logical SUPPRESS_UTM_PROJECTION
	integer ILONGLAT2UTM, IUTM2LONGLAT
	real*8 semimaj, semimin, scfa, north, east

	parameter (SUPPRESS_UTM_PROJECTION = .false.)
	parameter (ILONGLAT2UTM = 0, IUTM2LONGLAT = 1)
	parameter (semimaj=6378206.4d0, semimin=6356583.8d0, scfa=.9996d0)
	parameter (north=0.d0, east=500000.d0)

	PI=4.d0*datan(1.d0)
	TWO_PI=2.d0*PI
	degrad=PI/180.d0
	raddeg=180.d0/PI

	if(SUPPRESS_UTM_PROJECTION) then
	  if(iway==ILONGLAT2UTM) then
	    rx=rlon
	    ry=rlat
	  else
	    rlon=rx
	    rlat=ry
	  endif
	  return
	endif

c   Save original parameters

	rlon_save=rlon
	rlat_save=rlat
	rx_save=rx
	ry_save=ry

c   Define parameters of reference ellipsoid

	e2=1.d0-(semimin/semimaj)**2.d0
	e4=e2*e2
	e6=e2*e4
	ep2=e2/(1.d0-e2)

	if(iway==IUTM2LONGLAT) then
	  xx=rx
	  yy=ry
	else
	  dlon=rlon
	  dlat=rlat
	endif

c   Set Zone parameters. cm: central meridian.

	zone=dble(UTM_PROJECTION_ZONE)
	cm=zone*6.d0-183.d0
	cmr=cm*degrad

c   Lat/Lon to UTM conversion

	if(iway==ILONGLAT2UTM) then

	  rlon=degrad*dlon
	  rlat=degrad*dlat

	  delam=dlon-cm
	  if(delam<-180.d0) delam=delam+360.d0
	  if(delam>180.d0) delam=delam-360.d0
	  delam=delam*degrad

	  f1=(1.d0-e2/4.d0-3.d0*e4/64.d0-5.d0*e6/256.d0)*rlat
	  f2=3.d0*e2/8.d0+3.d0*e4/32.d0+45.d0*e6/1024.d0
	  f2=f2*dsin(2.d0*rlat)
	  f3=15.d0*e4/256.d0*45.d0*e6/1024.d0
	  f3=f3*dsin(4.d0*rlat)
	  f4=35.d0*e6/3072.d0
	  f4=f4*dsin(6.d0*rlat)
	  rm=semimaj*(f1-f2+f3-f4)

	  if(dlat==90.d0.or.dlat==-90.d0) then
	    xx=0.d0
	    yy=scfa*rm
	  else
	    rn=semimaj/dsqrt(1.d0-e2*dsin(rlat)**2)
	    t=dtan(rlat)**2
	    c=ep2*dcos(rlat)**2
	    a=dcos(rlat)*delam

	    f1=(1.d0-t+c)*a**3/6.d0
	    f2=5.d0-18.d0*t+t**2+72.d0*c-58.d0*ep2
	    f2=f2*a**5/120.d0
	    xx=scfa*rn*(a+f1+f2)
	    f1=a**2/2.d0
	    f2=5.d0-t+9.d0*c+4.d0*c**2
	    f2=f2*a**4/24.d0
	    f3=61.d0-58.d0*t+t**2+600.d0*c-330.d0*ep2
	    f3=f3*a**6/720.d0
	    yy=scfa*(rm+rn*dtan(rlat)*(f1+f2+f3))
	  endif

	  xx=xx+east
	  yy=yy+north

c   UTM to Lat/Lon conversion

	else

	  xx=xx-east
	  yy=yy-north
	  e1=dsqrt(1.d0-e2)
	  e1=(1.d0-e1)/(1.d0+e1)
	  rm=yy/scfa
	  u=1.d0-e2/4.d0-3.d0*e4/64.d0-5.d0*e6/256.d0
	  u=rm/(semimaj*u)

	  f1=3.d0*e1/2.d0-27.d0*e1**3/32.d0
	  f1=f1*dsin(2.d0*u)
	  f2=21.d0*e1**2/16.d0-55.d0*e1**4/32.d0
	  f2=f2*dsin(4.d0*u)
	  f3=151.d0*e1**3.d0/96.d0
	  f3=f3*dsin(6.d0*u)
	  rlat1=u+f1+f2+f3
	  dlat1=rlat1*raddeg

	  if(dlat1>=90.d0.or.dlat1<=-90.d0) then
	    dlat1=dmin1(dlat1,dble(90.d0))
	    dlat1=dmax1(dlat1,dble(-90.d0))
	    dlon=cm
	  else
	    c1=ep2*dcos(rlat1)**2
	    t1=dtan(rlat1)**2
	    f1=1.d0-e2*dsin(rlat1)**2
	    rn1=semimaj/dsqrt(f1)
	    r1=semimaj*(1.d0-e2)/dsqrt(f1**3)
	    d=xx/(rn1*scfa)

	    f1=rn1*dtan(rlat1)/r1
	    f2=d**2/2.d0
	    f3=5.d0*3.d0*t1+10.d0*c1-4.d0*c1**2-9.d0*ep2
	    f3=f3*d**2*d**2/24.d0
	    f4=61.d0+90.d0*t1+298.d0*c1+45.d0*t1**2-252.d0*ep2-3.d0*c1**2
	    f4=f4*(d**2)**3.d0/720.d0
	    rlat=rlat1-f1*(f2-f3+f4)
	    dlat=rlat*raddeg

	    f1=1.d0+2.d0*t1+c1
	    f1=f1*d**2*d/6.d0
	    f2=5.d0-2.d0*c1+28.d0*t1-3.d0*c1**2+8.d0*ep2+24.d0*t1**2
	    f2=f2*(d**2)**2*d/120.d0
	    rlon=cmr+(d-f1+f2)/dcos(rlat1)
	    dlon=rlon*raddeg
	    if(dlon<-180.d0) dlon=dlon+360.d0
	    if(dlon>180.d0) dlon=dlon-360.d0
	  endif

	endif

	if(iway==IUTM2LONGLAT) then
	  rlon=dlon
	  rlat=dlat
	  rx=rx_save
	  ry=ry_save
	else
	  rx=xx
	  ry=yy
	  rlon=rlon_save
	  rlat=rlat_save
	endif

	return
	end


      SUBROUTINE gaulag(x,w,n,alf)
      INTEGER n,MAXIT
      REAL alf,w(n),x(n)
      DOUBLE PRECISION EPS
      PARAMETER (EPS=3.D-14,MAXIT=10)
CU    USES gammln
      INTEGER i,its,j
      REAL ai,gammln
      DOUBLE PRECISION p1,p2,p3,pp,z,z1
      do 13 i=1,n
        if(i.eq.1)then
          z=(1.+alf)*(3.+.92*alf)/(1.+2.4*n+1.8*alf)
        else if(i.eq.2)then
          z=z+(15.+6.25*alf)/(1.+.9*alf+2.5*n)
        else
          ai=i-2
          z=z+((1.+2.55*ai)/(1.9*ai)+1.26*ai*alf/(1.+3.5*ai))*
     *(z-x(i-2))/(1.+.3*alf)
        endif
        do 12 its=1,MAXIT
          p1=1.d0
          p2=0.d0
          do 11 j=1,n
            p3=p2
            p2=p1
            p1=((2*j-1+alf-z)*p2-(j-1+alf)*p3)/j
11        continue
          pp=(n*p1-(n+alf)*p2)/z
          z1=z
          z=z1-p1/pp
          if(abs(z-z1).le.EPS)goto 1
12      continue
        pause 'too many iterations in gaulag'
1       x(i)=z
        w(i)=-exp(gammln(alf+n)-gammln(float(n)))/(pp*n*p2)
13    continue
      return
      END

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


!=======================================================================
! Created by
!     Keurfon Luu <keurfon.luu@mines-paristech.fr>
!     MINES ParisTech - Centre de Géosciences
!     PSL - Research University
!=======================================================================

module benchmark_functions

  use forlab, only : IPRE, RPRE, pi, ones, linspace, randu

  implicit none

  private
  public :: BenchmarkFunction

  abstract interface
    real(kind = RPRE) function optifunc(x)
      use forlab, only : RPRE
      import
      real(kind = RPRE), dimension(:), intent(in) :: x
    end function optifunc
  end interface

  type BenchmarkFunction
    procedure(optifunc), pointer, nopass :: func
    real(kind = RPRE), dimension(:), allocatable :: lower, upper
    integer(kind = IPRE) :: n_dim = 2
    real(kind = RPRE) :: min = 0.
  end type BenchmarkFunction

  interface BenchmarkFunction
    module procedure init_BenchmarkFunction
  end interface BenchmarkFunction

contains

  function init_BenchmarkFunction(func, n_dim) result(bf)
    type(BenchmarkFunction) :: bf
    character(len = *), intent(in) :: func
    integer(kind = IPRE), intent(in), optional :: n_dim

    if ( present(n_dim) ) then
      if ( n_dim .lt. 1 ) then
        print *, "Error: n_dim must be an integer > 0"
        stop
      else
        bf % n_dim = n_dim
      end if
    end if

    allocate(bf % lower(bf % n_dim), bf % upper(bf % n_dim))
    select case(func)
    case("ackley")
      bf % func => ackley
      bf % lower = -32.768
      bf % upper = 32.768
    case("griewank")
      bf % func => griewank
      bf % lower = -600.
      bf % upper = 600.
    case("quartic")
      bf % func => quartic
      bf % lower = -1.28
      bf % upper = 1.28
    case("quartic_noise")
      bf % func => quartic_noise
      bf % lower = -1.28
      bf % upper = 1.28
    case("rastrigin")
      bf % func => rastrigin
      bf % lower = -5.12
      bf % upper = 5.12
    case("rosenbrock")
      bf % func => rosenbrock
      bf % lower = -5.12
      bf % upper = 5.12
    case("sphere")
      bf % func => sphere
      bf % lower = -5.12
      bf % upper = 5.12
    case("styblinski-tang")
      bf % func => styblinski_tang
      bf % lower = -5.12
      bf % upper = 5.12
    case default
      print *, "Error: unknown benchmark function '" // trim(func) // "'"
      stop
    end select
    return
  end function init_BenchmarkFunction

  real(kind = RPRE) function ackley(x)
    real(kind = RPRE), dimension(:), intent(in) :: x
    integer(kind = IPRE) :: nd
    real(kind = RPRE) :: sum1, sum2, e = 2.7182818284590451d0

    nd = size(x)
    sum1 = sqrt( 1.0d0 / nd * sum( x**2 ) )
    sum2 = 1.0d0 / nd * sum( cos( 2.0d0 * pi * x ) )
    ackley = 20.0d0 + e - 20.0d0 * exp( -0.2d0 * sum1 ) - exp(sum2)
    return
  end function ackley

  real(kind = RPRE) function griewank(x)
    real(kind = RPRE), dimension(:), intent(in) :: x
    integer(kind = IPRE) :: nd
    real(kind = RPRE) :: sum1, prod1

    nd = size(x)
    sum1 = sum( x**2 ) / 4000.0d0
    prod1 = product( cos( x / sqrt( linspace(1, nd, nd) ) ) )
    griewank = 1.0d0 + sum1 - prod1
    return
  end function griewank

  real(kind = RPRE) function quartic(x)
    real(kind = RPRE), dimension(:), intent(in) :: x
    integer(kind = IPRE) :: nd

    nd = size(x)
    quartic = sum( linspace(1, nd, nd) * x**4 )
    return
  end function quartic

  real(kind = RPRE) function quartic_noise(x)
    real(kind = RPRE), dimension(:), intent(in) :: x

    quartic_noise = quartic(x) + randu()
    return
  end function quartic_noise

  real(kind = RPRE) function rastrigin(x)
    real(kind = RPRE), dimension(:), intent(in) :: x
    integer(kind = IPRE) :: nd
    real(kind = RPRE) :: sum1

    nd = size(x)
    sum1 = sum( x**2 - 10.0d0 * cos( 2.0d0 * pi * x ) )
    rastrigin = 10.0d0 * nd + sum1
    return
  end function rastrigin

  real(kind = RPRE) function rosenbrock(x)
    real(kind = RPRE), dimension(:), intent(in) :: x
    integer(kind = IPRE) :: nd
    real(kind = RPRE) :: sum1, sum2

    nd = size(x)
    sum1 = sum( ( x(2:) - x(:nd-1)**2 )**2 )
    sum2 = sum( ( 1.0d0 - x(:nd-1) )**2 )
    rosenbrock = 100.0d0 * sum1 + sum2
    return
  end function rosenbrock

  real(kind = RPRE) function schwefel(x)
    real(kind = RPRE), dimension(:), intent(in) :: x
    integer(kind = IPRE) :: nd
    real(kind = RPRE) :: sum1

    nd = size(x)
    sum1 = sum( x * sin( sqrt( abs(x) ) ) )
    schwefel = 418.9829d0 * nd - sum1
    return
  end function schwefel

  real(kind = RPRE) function sphere(x)
    real(kind = RPRE), dimension(:), intent(in) :: x

    sphere = sum( x**2 )
    return
  end function sphere

  real(kind = RPRE) function styblinski_tang(x)
    real(kind = RPRE), dimension(:), intent(in) :: x
    real(kind = RPRE) :: sum1

    sum1 = sum( x**4 - 16.0d0 * x**2 + 5.0d0 * x )
    styblinski_tang = sum1 / 2.0d0 + 39.16599 * size(x)
    return
  end function styblinski_tang

end module benchmark_functions


! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
! See https://llvm.org/LICENSE.txt for license information.
! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
!
! test for addition operation of quad precision in flang2.

program test
  integer, parameter :: n = 4
  real(16) :: qa1, qa2, q1, q2, qadd
  real(16) :: result(n), expect(n)

  qadd(qa1, qa2) = qa1 + qa2

  q1 = 1.0_16
  q2 = 2.0_16

  expect = (/ 1.0_16, 3.0_16, 1.0_16, -1.0_16 /)

  ! op2 is 0.0_16
  result(1) = q1 + 0.0_16
  ! op1 and op2 is constant
  result(2) = qadd(1.0_16, 2.0_16)
  ! -a + b
  result(3) = -q1 + q2
  ! a + -b
  result(4) = q1 + (-q2)

  if (any(result /= expect)) STOP 1

  print *, 'PASS'

end program


! --------------------------------------------------------------------
!
! Copyright (C) 2015 Rocco Meli
!
! This program is free software: you can redistribute it and/or modify
! it under the terms of the GNU General Public License as published by
! the Free Software Foundation, either version 3 of the License, or
! (at your option) any later version.
!
! This program is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
! GNU General Public License for more details.
!
! You should have received a copy of the GNU General Public License
! along with this program.  If not, see <http://www.gnu.org/licenses/>.
!
! ---------------------------------------------------------------------

PROGRAM boys_test

    USE NUCLEAR, only: boys

    ! ------------------------------------------------------------------------
    !
    ! Source:
    !   On the evaluation of Boys functions using downward  recursion relation
    !   B. A. Mamedov
    !   Journal of Mathematical Chemistry
    !   2004
    !
    ! ------------------------------------------------------------------------

    WRITE(*,*) 8, 16, boys(8,16.0D0)
    WRITE(*,*) 15, 27, boys(15,27.0D0)
    WRITE(*,*) 20, 30, boys(2,30.0D0)
    WRITE(*,*) 25, 13, boys(25,13.0D0)
    WRITE(*,*) 75, 30, boys(75,30.0D0)

    WRITE(*,*)

    WRITE(*,*) 8, 42, boys(8,42.0D0)
    WRITE(*,*) 16, 50, boys(16,50.0D0)
    WRITE(*,*) 21, 56, boys(21,56.0D0)
    WRITE(*,*) 12, 60, boys(12,60.0D0)
    WRITE(*,*) 18, 58, boys(18,58.0D0)

    WRITE(*,*)
    WRITE(*,*) 8, 63, boys(8,63.0D0)
    WRITE(*,*) 33, 85, boys(33,85.0D0)
    WRITE(*,*) 100, 120, boys(100,120.0D0)

END PROGRAM boys_test


! RUN: %S/test_modfile.sh %s %f18 %t
! Test modfiles for entities with initialization
module m
  integer, parameter :: k8 = 8
  integer(8), parameter :: k4 = k8/2
  integer, parameter :: k1 = 1
  integer(k8), parameter :: i = 2_k8
  real :: r = 2.0_k4
  character(10, kind=k1) :: c = k1_"asdf"
  character(10), parameter :: c2 = k1_"qwer"
  complex*16, parameter :: z = (1.0_k8, 2.0_k8)
  complex*16, parameter :: zn = (-1.0_k8, 2.0_k8)
  type t
    integer :: a = 123
    type(t), pointer :: b => null()
  end type
  type(t), parameter :: x = t(456)
  type(t), parameter :: y = t(789, null())
end

!Expect: m.mod
!module m
!  integer(4),parameter::k8=8_4
!  integer(8),parameter::k4=4_8
!  integer(4),parameter::k1=1_4
!  integer(8),parameter::i=2_8
!  real(4)::r
!  character(10_4,1)::c
!  character(10_4,1),parameter::c2=1_"qwer      "
!  complex(8),parameter::z=(1._8,2._8)
!  complex(8),parameter::zn=(-1._8,2._8)
!  type::t
!    integer(4)::a=123_4
!    type(t),pointer::b=>NULL()
!  end type
!  type(t),parameter::x=t(a=456_4,b=NULL())
!  type(t),parameter::y=t(a=789_4,b=NULL())
!  intrinsic::null
!end


program expr_01
implicit none
integer :: x
x = (2+3)*5
if (x == 25) error stop
end program


program ch0707v2
    ! Longitude from -180 to +180
    implicit none

    integer, dimension(-180:180) :: time = 0
    integer :: degree
    integer :: value

    do degree = -180, 179
        value = degree/15
        time(degree) = value
    end do
    do degree = -180, 180
        print *, degree, ' ', time(degree)
    end do
end program


module LSQ

IMPLICIT NONE

contains

	Subroutine LSQM(a,y,w, x,d, s, r, cond)

! m - количество уравнений
! n - количество неизвестных
! a(m,n) - матрица плана
! y(m) - столбец правых частей,  w(m) -  столбец весов;
! x(n) - ответ, d(n) - среднеквадратичные ошибки x;
!  s - среднеквадратичная ошибка единицы веса;
!  r(n,n) - корреляционная матрица.
! cond  Число обусловленности

	real(8), intent(in)  :: a(:,:), y(:), w(:)
	real(8), intent(out) :: x(:), d(:), s, r(:,:)
    real(8), intent(out) :: cond

	integer i,j,k
    real(8) :: u
    real(8) :: c(size(x))

	integer :: m,n

	m=size(a, dim=1)
	n=size(a, dim=2)

	if (size(y)/=m .or. size(w)/=m .or. size(x)/=n .or. size(d)/=n .or. size(r,dim=1)/=n .or. size(r,dim=2) /= n) then
	 STOP 'Incorrect parameters of LSQM'
	endif

      do i=1,n

       do j=1,i
        u=0.0_8
        do k=1,m
	     u=u+a(k,i)*a(k,j)*w(k)
	    end do
        r(i,j)=u; r(j,i)=u
       end do

	   u=0.0_8
       do k=1,m
        u=u+a(k,i)*y(k)*w(k)
       end do
       c(i)=u

	  end do ! i=1,n

      !do i=1,n
	  ! print "(20F8.2)",(R(i,j),J=1,N)
	  !end do

      cond=Cond1(r) ! Число обусловленности
      call Invert(r)
      call Multiply(r,c,x)

      s=0.0_8
      do k=1,m
       u=0.0_8
	   do i=1,n
        u=u+a(k,i)*x(i)
	   enddo
       s=s+(u-y(k))**2 * w(k)
	  enddo
      s=sqrt(s/(m-n))

	  do i=1,n
       d(i)=s*sqrt(r(i,i))
	  enddo

      do i=1,n
       do j=1,i-1
          r(i,j)=r(i,j)/sqrt(r(i,i)*r(j,j))
          r(j,i)=r(i,j)
       enddo
	  enddo
      do i=1,n
       r(i,i)=1.0_8
	  enddo

	end subroutine

     Subroutine Multiply(a,b,c)
! Умножение матрицы на вектор c[m]:=a[m,n]*b[n]
	real(8), intent(in)  :: a(:,:),b(:)
	real(8), intent(out) :: c(:)
	integer m,n
	integer i,k
    real(8) :: t

    m=size(a,dim=1);	n=size(a,dim=2)
	if (size(b)/=n .or. size(c)/=m) then
	 STOP 'Incompatible size in Multiply'
	endif

      do i=1,m
       t=0.0
       do k=1,n
        t=t+a(i,k)*b(k)
       enddo
       c(i)=t
	enddo

	end subroutine

	Subroutine Invert(D) ! Обращение матрицы
	real(8), intent(inout) :: D(:,:)			 ! Исходная матрица
	integer :: N2,i,j,k,is
	real(8) :: t
	real(8) a( size(D,dim=1), 2*size(D,dim=1) )
	integer :: N
	N=size(D,dim=1)
	N2=2*N

!		Наращивание с единичной матрицей

	DO i=1,N
	 DO j=1,N
	  a(i,j)=D(i,j)
	 END DO
	END DO
	DO i=1,N
	 DO j=1,N
	  IF (i==j) THEN
	            a(i,j+N)=1
			   ELSE
				a(i,j+N)=0
	  END IF
	 END DO
	END DO
!	Начало обращения
	DO i=1,N
	 k=i
	 is=0
	 DO WHILE (a(k,i)==0)
	  is=1
	  IF (k<N) THEN
	              K=K+1
			   ELSE
				STOP 'Matrix is particular'
	  ENDIF
	 END DO ! WHILE

	 IF (is==1) THEN
	  DO J=1,N2
	     t=a(k,j)
	     a(k,j)=a(i,j)
	     a(i,j)=t
	  END DO
	 END IF

	 DO j=N2,i,-1
	  a(i,j)=a(i,j)/a(i,i)
	 ENDDO

	 DO k=1,N
	  IF (k /= i) THEN
	   DO j=N2,i,-1
	     a(k,j)=a(k,j)-a(i,j)*a(k,i)
	   ENDDO
	  ENDIF
	 ENDDO

	ENDDO

	DO i=1,N
	 DO j=1,N
	  D(i,j)=a(i,j+N)
	 ENDDO
	ENDDO

  	END Subroutine

 REAL(4) Function Ranorm(s)
 REAL(4), INTENT(IN) :: S
 REAL(4) :: a,x
 INTEGER(4) :: i
  a=0
  DO I=1, 12
   CALL RANDOM(x)
   a=a+x
  END DO
  Ranorm=(a-6.0)*s
 END FUNCTION RANORM

SUBROUTINE INVMATRIX(A)

      IMPLICIT NONE
      REAL*8    :: A(:,:)
      INTEGER   :: MMM
      REAL*8                :: C0,C1,SIGMA
      INTEGER               :: I,J,K,M,METHOD,N1,N2
      INTEGER               :: LLL

      Real*8, Allocatable   :: WK(:,:), BK(:,:), E(:,:), U(:,:)
      Real*8, Allocatable   :: VM(:),WM(:)

      MMM=size(A,Dim=1)

!  MMM=size(WK,Dim=1)         ! MMM is the number of rows
!  LLL=size(WK,Dim=2)         ! LLL is the number of columns

      N1=MMM
      LLL=2*MMM
      N2=LLL
      Allocate( WK(N1,N2), BK(N1,N2),E(N1,N1),U(N1,N1) )
      Allocate( VM(N1), WM(N1) )

      DO I=1,MMM
        DO J=1,MMM
          E(I,J)=0.0D+00
        ENDDO
        E(I,I)=1.0D+00
      ENDDO

      DO I=1,MMM
        DO J=1,MMM
          WK(I,J)=A(I,J)
          WK(I,J+MMM)=E(I,J)
        ENDDO
      ENDDO

      DO 1000 M=1,MMM-1

        METHOD=1
        DO I=M+1,MMM
          IF (WK(I,M).NE.0.0D+00) METHOD=0
        ENDDO
        IF (METHOD.EQ.1) THEN
          C0=WK(M,M)
          DO I=M,LLL
            WK(M,I)=WK(M,I)/C0
          ENDDO
          GOTO 1000
        ELSE
          DO I=1,MMM
            VM(I)=0.0D+00
          ENDDO
          DO I=M,MMM
            VM(I)=WK(I,M)
          ENDDO
          C0=0.0D+00
          DO I=M,MMM
            C0=C0+VM(I)*VM(I)
          ENDDO
          IF (VM(M).GE.0.0D+00) THEN
            SIGMA=DSQRT(C0)
          ELSE
            SIGMA=-DSQRT(C0)
          END IF
          DO I=1,MMM
            WM(I)=VM(I)
          ENDDO
          WM(M)=WM(M)+SIGMA
          C0=0.0D+00
          DO I=M,MMM
            C0=C0+WM(I)*WM(I)
          ENDDO
          C1=DSQRT(C0)
          DO I=M,MMM
            WM(I)=WM(I)/C1
          ENDDO
          DO I=1,MMM
            DO J=1,MMM
              U(I,J)=E(I,J)-2.0D+00*WM(I)*WM(J)
            ENDDO
          ENDDO
          DO I=1,MMM
            DO J=1,LLL
              C0=0.0D+00
              DO K=1,MMM
                C0=C0+U(I,K)*WK(K,J)
              ENDDO
              BK(I,J)=C0
            ENDDO
          ENDDO
          DO I=1,MMM
            DO J=1,LLL
              WK(I,J)=BK(I,J)
            ENDDO
          ENDDO
          C0=WK(M,M)
          DO I=M,LLL
            WK(M,I)=WK(M,I)/C0
          ENDDO
        END IF
1000  CONTINUE

      C0=WK(MMM,MMM)
      DO I=MMM,LLL
        WK(MMM,I)=WK(MMM,I)/C0
      ENDDO

      DO K=MMM,2,-1
        DO I=K-1,1,-1
          C0=WK(I,K)
          DO J=K,LLL
            WK(I,J)=WK(I,J)-WK(K,J)*C0
          ENDDO
        ENDDO
      ENDDO

      DO I=1,MMM
        DO J=1,MMM
          A(I,J)=WK(I,J+MMM)
        ENDDO
      ENDDO

      DEAllocate( WK, BK,E,U )
      DEAllocate( VM, WM )

END SUBROUTINE INVMATRIX

REAL(8) FUNCTION DETERMINANT(A)
REAL(8),INTENT(IN)    :: A(:,:)
INTEGER(4)   :: N
REAL(8)    :: DET
REAL*8               :: T,D,MAX
REAL*8               :: B(size(A,Dim=1),size(A,Dim=1))
INTEGER              :: I,J,K

N=size(A,Dim=1)

DO I=1,N
  DO J=1,N
    B(I,J)=A(I,J)
  ENDDO
ENDDO

D=1.0D+00

DO K=1,N
  MAX=0.0D+00
  DO I=K,N
    T=B(I,K)
    IF (DABS(T).GT.DABS(MAX)) THEN
      MAX=T
      J=I
    END IF
  END DO
  IF (MAX.EQ.0.0D+00) THEN
    D=0.0D+00
    GOTO 100
  END IF
  IF (J.NE.K) THEN
    D=-D
    DO I=K,N
      T=B(J,I)
      B(J,I)=B(K,I)
      B(K,I)=T
    END DO
  END IF
  DO I=K+1,N
    T=B(I,K)/MAX
    DO J=K+1,N
      B(I,J)=B(I,J)-T*B(K,J)
    END DO
  END DO
  D=D*B(K,K)
END DO

100 DET=D

DETERMINANT=DET

END FUNCTION DETERMINANT

REAL(8) FUNCTION MATRIXNORM1(D)
	real(8), intent(in) :: D(:,:)		! Исходная матрица
    INTEGER(4) :: N
	INTEGER(4) :: I,J
	REAL(8) :: S
	N = size(D,dim=1)
	MATRIXNORM1=0
	DO J=1,N
	 S=0
	 DO I=1,N
	  S=S+DABS(D(I,J))
	 END DO
	 IF (S>MATRIXNORM1) MATRIXNORM1=S
	END DO
END FUNCTION

REAL(8) FUNCTION COND1(D)
 	real(8), intent(in) :: D(:,:)
	real(8) :: R(size(D,dim=1),size(D,dim=1))
    R=D
	CALL INVERT(R)
	COND1=MATRIXNORM1(D)*MATRIXNORM1(R)
END FUNCTION

end module LSQ


subroutine gmres_Laplace(x,d,w,bg,dg,ien,id,lp_el,n_el)
	use fluid_variables, only: nsd,nn,ne,nen
	implicit none
	integer inner, outer
	parameter (inner = 50) ! Laplace equation inner 50 should be sufficient
	parameter (outer = 5)  ! Laplace equation outer 5 should be sufficient
	integer ien(nen,ne)
	real* 8 x(nsd,nn)
	real* 8 d(nn)
	real* 8 bg(nn), dg(nn), w(nn)
	real* 8 Hm(inner+1,inner) !Henssenberg matrix
	real* 8 Vm(nn, inner+1) ! Krylov space matrix
!--------------------------------
	integer lp_el(n_el)
	integer n_el
	integer id(nn)
!--------------------------------
	integer i,j,iouter,icount,INFO
	integer e1(inner+1)
	real* 8 x0(nn)
	real* 8 beta(inner+1)
	real* 8 eps
	real* 8 r0(nn)
	real* 8 rnorm, rnorm0,err
        real* 8 dv(nn)
	real* 8 Vy(nn)
        real* 8 avloc(nn)
	real* 8 temp(nn)
	character(1) TRAN
	real* 8 workls(2*inner)

	eps = 1.0e-6
	e1(:) = 0.0
	e1(1) = 1
	x0(:) = 0.0
	iouter = 1
	r0(:) = bg(:)
	TRAN = 'N'
	avloc(:) = 0.0
!	w(:) = 1
        call getnorm(r0,r0,nn,rnorm0)
        rnorm = sqrt(rnorm0)

!write(*,*) 'rnorm0', rnorm0

!!!!!!!!!!!!!!!start outer loop!!!!!!!!!
	do 111, while((iouter .le. outer) .and. (rnorm .ge. eps))

	Vm(:,:) = 0.0
	do icount = 1, nn
	   Vm(icount,1) = r0(icount)/rnorm
	end do ! get V1

	   beta(:) = rnorm*e1(:) ! get beta*e1
	   Hm(:,:) = 0.0
!!!!!!!!!!!!!!!!start inner loop!!!!!!!!!!!!!
	   do j=1,inner

		 do icount=1, nn
		    dv(icount) = 1/w(icount)*Vm(icount,j)
		 end do!!!!!!!!!!calcule eps*inv(P)*V1

		avloc(:) = 0.0d0
		call blockgmres_Laplace(x,dv,avloc,ien,lp_el,n_el)
!		avloc(:) = (-avloc(:)+bg(:))/eps ! get Av,bg=-r(u)
		call setid(avloc,id,1)
!do icount=1,nn
!                write(*,*) 'node av', icount,avloc(icount)
!end do
		continue
	      do i=1,j
		do icount = 1, nn
		   Hm(i,j)=Hm(i,j)+avloc(icount)*Vm(icount,i)

		end do
	      end do  ! construct AVj and hi,j

	      do icount = 1, nn
		 do i=1,j
		   Vm(icount,j+1) = Vm(icount,j+1)-Hm(i,j)*Vm(icount,i)
		 end do
		 Vm(icount,j+1)=Vm(icount,j+1)+avloc(icount)
	      end do  ! construct v(j+1)

	      do icount = 1, nn
		 temp(icount)=Vm(icount,j+1)
	      end do
	      call getnorm(temp, temp, nn,rnorm0)

	      Hm(j+1,j) = sqrt(rnorm0)

	      do icount = 1, nn
 		 Vm(icount,j+1)=Vm(icount,j+1)/Hm(j+1,j)
	      end do
	  end do  ! end inner loop

!==========================================================================
!	call DGELS(TRAN,inner+1,inner,1,Hm,inner+1,beta,inner+1,workls,2*inner,INFO)
	call givens(Hm,inner,beta)
!!!!!!!!!!!!beta(1:inner) is ym, the solution!!!!!!!!!!!!!!!!!!!!!!!!!
	Vy(:) = 0
	do icount=1,nn
	   do i=1,inner
	      Vy(icount)=Vy(icount)+Vm(icount,i)*beta(i)
	   end do
	   x0(icount)=x0(icount)+Vy(icount)
	end do ! calculate Xm
!write(*,*)'x0=',x0(:)
	do icount = 1, nn
	   dv(icount) = 1/w(icount)*x0(icount)
	end do

!write(*,*) dv(:)

	avloc(:) = 0.0d0
	call blockgmres_Laplace(x,dv,avloc,ien,lp_el,n_el)
!	avloc(:) = (-avloc(:)+bg(:))/eps
	call setid(avloc,id,1)

!!!!!!!!!!calculate AXm
	do icount=1,nn
	   r0(icount) = bg(icount)-avloc(icount)
	end do !update r0=f-AX0
	call getnorm(r0,r0,nn,rnorm0)
	err = sqrt(rnorm0)

	rnorm = sqrt(rnorm0)
	iouter = iouter + 1

!	write(*,*) '***** Indicator Laplace Eq err******=',err
111     continue  ! end outer loop
!write(*,*)'x0_2=',x0(:)

	dg(:) = 1/w(:)*x0(:) ! unscaled x0
!write(*,*)'dg=',dg(:)
!write(*,*)'w=',w(:)
!stop
	return
	end


!*********************************************************************************
! Part of the MEDINA: MECCA - KPP Fortran to CUDA source-to-source pre-processor
!*********************************************************************************
!
! Extracted Minimal Definitions of machine precision and physical constants
! as Fortran PARAMETERs for MESSy
!
! Author: Michail Alvanos
!
! Original Authors:
!  - Rolf Sander
!  - Patrick Joeckel
!

MODULE messy_main_constants_mem

  INTEGER, PARAMETER :: sp = SELECTED_REAL_KIND(6,37)
  INTEGER, PARAMETER :: dp = SELECTED_REAL_KIND(12,307)
  REAL(DP), PARAMETER :: TINY_DP = TINY(0._dp) ! mz_rs_20060114
  REAL(DP), PARAMETER :: HUGE_DP = HUGE(0._dp) ! mz_rs_20100409

  ! PHYSICAL CONSTANTS (CODATA Recommended Values, 2010,
  ! http://physics.nist.gov/cuu/Constants/)
  REAL(dp), PARAMETER :: pi       = 3.14159265358979323846_dp
  REAL(dp), PARAMETER :: R_gas    = 8.3144621_dp     ! R [J/K/mol]
  REAL(dp), PARAMETER :: h_Planck = 6.62606957E34_dp ! Planck constant [Js]
  REAL(dp), PARAMETER :: c_light  = 2.99792458E8_dp  ! speed of light [m/s]
  REAL(dp), PARAMETER :: stbo     = 5.670373E-8_dp   ! Stephan-Boltzmann constant [W/m2/K4]
  REAL(dp), PARAMETER :: N_A      = 6.02214129E23_dp ! Avogadro constant [1/mol]
  REAL(dp), PARAMETER :: N_A_kmol = 6.02214129E26_dp ! Avogadro constant [1/kmol]
  REAL(dp), PARAMETER :: g        = 9.80665_dp       ! gravity acceleration [m/s2]
  REAL(dp), PARAMETER :: T0       = 298.15_dp        ! standard temperature [K]
  REAL(dp), PARAMETER :: T0_INV   = 1._DP / T0       ! 1/T0 [1/K]
  REAL(dp), PARAMETER :: atm2Pa   = 101325._dp       ! conversion from [atm] to [Pa]

END MODULE messy_main_constants_mem


      subroutine clawpack46_qinit(maxmx,maxmy,meqn,mbc,
     &      mx,my,xlower,ylower,dx,dy,q,maux,aux)

      implicit none

      integer maxmx, maxmy, meqn, mbc, mx, my, maux
      double precision xlower, ylower, dx, dy
      integer*8 cont, get_context
      integer blockno, fc2d_clawpack46_get_block
      double precision q(1-mbc:maxmx+mbc, 1-mbc:maxmy+mbc, meqn)
      double precision aux(1-mbc:maxmx+mbc, 1-mbc:maxmy+mbc, maux)

      integer i,j
      double precision xc,yc,xp,yp,zp
      double precision cosine_bell_sum

      double precision a,b

      cont = get_context()
      blockno = fc2d_clawpack46_get_block()

      a = -0.8d0
      b = 0.9d0

      do j = 1-mbc,my+mbc
         yc = ylower + (j-0.5d0)*dy
         do i = 1-mbc,mx+mbc
            xc = xlower + (i-0.5d0)*dx
            call fclaw2d_map_c2m(cont,
     &            blockno,xc,yc,xp,yp,zp)
            q(i,j,1) = cosine_bell_sum(xp,yp,zp)
            if (meqn .eq. 2) then
c              # Set non-linear relationship between two tracers
               q(i,j,2) = a*q(i,j,1)**2 + b
            endif
         enddo
      enddo

      return
      end


subroutine loglcbas_to_lcbas(loglcbas,lcbas)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    loglcbas_to_lcbas  tlm for loglcbas to lcbas
!   prgmmr: zhu               org: np20                date: 2011-06-30
!
! abstract: get lcbas from logarithm of lcbas
!
! program history log:
!   2011-06-30  zhu
!
!   input argument list:
!      loglcbas
!
!   output argument list:
!      lcbas
!
! attributes:
!   language: f90
!   machine:  ibm RS/6000 SP
!
!$$$
  use kinds, only: r_kind,i_kind
  use gridmod, only: lat2,lon2
  use derivsmod, only: dlcbasdlog

  implicit none
  real(r_kind),intent(in   ) :: loglcbas(lat2,lon2)
  real(r_kind),intent(  out) :: lcbas(lat2,lon2)

  integer(i_kind) i,j

  do j=1,lon2
     do i=1,lat2
        lcbas(i,j)=dlcbasdlog(i,j)*loglcbas(i,j)
     end do
  end do
end subroutine loglcbas_to_lcbas

subroutine loglcbas_to_lcbas_ad(loglcbas,lcbas)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    loglcbas_to_lcbas_ad  adjoint of loglcbas_to_lcbas
!   prgmmr: zhu               org: np20                date: 2011-06-30
!
! abstract: adjoint of loglcbas_to_lcbas
!
! program history log:
!   2011-06-30  zhu
!
!   input argument list:
!      loglcbas
!      lcbas
!
!   output argument list:
!      loglcbas
!      lcbas
!
! attributes:
!   language: f90
!   machine:  ibm RS/6000 SP
!
!$$$
  use kinds, only: r_kind,i_kind
  use constants, only: zero
  use gridmod, only: lat2,lon2
  use derivsmod, only: dlcbasdlog

  implicit none
  real(r_kind),intent(inout) :: loglcbas(lat2,lon2)
  real(r_kind),intent(inout) :: lcbas(lat2,lon2)

  integer(i_kind) i,j

  do j=1,lon2
     do i=1,lat2
        loglcbas(i,j)=loglcbas(i,j)+dlcbasdlog(i,j)*lcbas(i,j)
        lcbas(i,j)=zero
     end do
  end do
end subroutine loglcbas_to_lcbas_ad