submodule (real_transform_routines) multiple_real_forward

contains

    module subroutine rfftmf(lot, jump, n, inc, r, lenr, wsave, lensav, work, lenwrk, ierror)
        !
        ! rfftmf: real forward fft, 1d, multiple vectors.
        !
        !  purpose:
        !
        !  rfftmf computes the one-dimensional fourier transform of multiple
        !  periodic sequences within a real array.  this transform is referred
        !  to as the forward transform or fourier analysis, transforming the
        !  sequences from physical to spectral space.
        !
        !  this transform is normalized since a call to rfftmf followed
        !  by a call to rfftmb (or vice-versa) reproduces the original array
        !  within roundoff error.
        !
        !  parameters:
        !
        !  integer lot, the number of sequences to be transformed
        !  within array r.
        !
        !  integer jump, the increment between the locations, in
        !  array r, of the first elements of two consecutive sequences to be
        !  transformed.
        !
        !  integer n, the length of each sequence to be
        !  transformed.  the transform is most efficient when n is a product of
        !  small primes.
        !
        !  integer inc, the increment between the locations,
        !  in array r, of two consecutive elements within the same sequence.
        !
        !  input/real r(lenr), real array containing lot
        !  sequences, each having length n.  r can have any number of dimensions, but
        !  the total number of locations must be at least lenr.  on input, the
        !  physical data to be transformed, on output the spectral data.
        !
        !  integer lenr, the dimension of the r array.
        !  lenr must be at least (lot-1)*jump + inc*(n-1) + 1.
        !
        !  input, real (wp) wsave(lensav).  wsave's contents must be
        !  initialized with a call to rfftmi before the first call to routine rfftmf
        !  or rfftmb for a given transform length n.
        !
        !  integer lensav, the dimension of the wsave array.
        !  lensav must be at least n + int(log(real(n))) + 4.
        !
        !  workspace, real (wp) work(lenwrk).
        !
        !  integer lenwrk, the dimension of the work array.
        !  lenwrk must be at least lot*n.
        !
        !  integer ierror, error_flag.
        !  0, successful exit;
        !  1, input parameter lenr not big enough;
        !  2, input parameter lensav not big enough;
        !  3, input parameter lenwrk not big enough;
        !  4, input parameters inc, jump, n, lot are not consistent.
        !
        !--------------------------------------------------------------
        ! Dummy arguments
        !--------------------------------------------------------------
        integer (ip), intent (in)     :: lot
        integer (ip), intent (in)     :: jump
        integer (ip), intent (in)     :: n
        integer (ip), intent (in)     :: inc
        real (wp),    intent (in out) :: r(lenr)
        integer (ip), intent (in)     :: lenr
        real (wp),    intent (in)     :: wsave(lensav)
        integer (ip), intent (in)     :: lensav
        real (wp),    intent (out)    :: work(lenwrk)
        integer (ip), intent (in)     :: lenwrk
        integer (ip), intent (out)    :: ierror
        !--------------------------------------------------------------

        !
        !==> Check validity of input arguments
        !
        if (lenr < (lot-1)*jump + inc*(n-1) + 1) then
            ierror = 1
            call fft_error_handler('rfftmf ', 6)
            return
        else if (lensav < n + int(log(real(n, kind=wp) )/log(TWO)) +4) then
            ierror = 2
            call fft_error_handler('rfftmf ', 8)
            return
        else if (lenwrk < lot*n) then
            ierror = 3
            call fft_error_handler('rfftmf ', 10)
            return
        else if (.not. fft_consistent(inc,jump,n,lot)) then
            ierror = 4
            call fft_error_handler('rfftmf ', -1)
            return
        else
            ierror = 0
        end if

        !
        !==> Perform transform
        !
        if (n /= 1) call mrftf1(lot, jump, n, inc, r, work, wsave, wsave(n+1))

    end subroutine rfftmf

    subroutine mrftf1(m,im,n,in,c,ch,wa,fac)
        !--------------------------------------------------------------
        ! Dummy arguments
        !--------------------------------------------------------------
        integer (ip) in
        integer (ip) m
        integer (ip) n
        real (wp) c(in,*)
        real (wp) ch(m,*)
        real (wp) fac(15)
        integer (ip) i
        integer (ip) idl1
        integer (ip) ido
        integer (ip) im
        integer (ip) iip
        integer (ip) iw
        integer (ip) ix2
        integer (ip) ix3
        integer (ip) ix4
        integer (ip) j
        integer (ip) k1
        integer (ip) kh
        integer (ip) l1
        integer (ip) l2
        integer (ip) m2
        integer (ip) modn
        integer (ip) na
        integer (ip) nf
        integer (ip) nl
        real (wp) sn
        real (wp) tsn
        real (wp) tsnm
        real (wp) wa(n)

        nf = int(fac(2), kind=ip)
        na = 1
        l2 = n
        iw = n

        do k1=1,nf
            kh = nf-k1
            iip = int(fac(kh+3), kind=ip)
            l1 = l2/iip
            ido = n/l2
            idl1 = ido*l1
            iw = iw-(iip-1)*ido
            na = 1-na
            select case (iip)
                case (2)
                    if (na == 0) then
                        call mradf2(m,ido,l1,c,im,in,ch,1,m,wa(iw))
                    else
                        call mradf2(m,ido,l1,ch,1,m,c,im,in,wa(iw))
                    end if
                case(3)
                    ix2 = iw+ido
                    if (na == 0) then
                        call mradf3(m,ido,l1,c,im,in,ch,1,m,wa(iw),wa(ix2))
                    else
                        call mradf3(m,ido,l1,ch,1,m,c,im,in,wa(iw),wa(ix2))
                    end if
                case (4)
                    ix2 = iw+ido
                    ix3 = ix2+ido
                    if (na == 0) then
                        call mradf4(m,ido,l1,c,im,in,ch,1,m,wa(iw),wa(ix2),wa(ix3))
                    else
                        call mradf4(m,ido,l1,ch,1,m,c,im,in,wa(iw),wa(ix2),wa(ix3))
                    end if
                case(5)
                    ix2 = iw+ido
                    ix3 = ix2+ido
                    ix4 = ix3+ido
                    if (na == 0) then
                        call mradf5(m,ido,l1,c,im,in,ch,1,m,wa(iw),wa(ix2),wa(ix3),wa(ix4))
                    else
                        call mradf5(m,ido,l1,ch,1,m,c,im,in,wa(iw),wa(ix2),wa(ix3),wa(ix4))
                    end if
                case default
                    if (ido == 1) then
                        na = 1-na
                    end if
                    if (na == 0) then
                        call mradfg(m,ido,iip,l1,idl1,c,c,c,im,in,ch,ch,1,m,wa(iw))
                        na = 1
                    else
                        call mradfg(m,ido,iip,l1,idl1,ch,ch,ch,1,m,c,c,im,in,wa(iw))
                        na = 0
                    end if
            end select
            l2 = l1
        end do

        sn = ONE/n
        tsn =  TWO/n
        tsnm = -tsn
        modn = mod(n,2)

        if (modn /= 0) then
            nl = n-1
        else
            nl = n-2
        end if

        if (na == 0) then
            m2 = 1-im

            do i=1,m
                m2 = m2+im
                c(m2,1) = sn*ch(i,1)
            end do

            do j=2,nl,2
                m2 = 1-im
                do i=1,m
                    m2 = m2+im
                    c(m2,j) = tsn*ch(i,j)
                    c(m2,j+1) = tsnm*ch(i,j+1)
                end do
            end do

            if (modn == 0) then
                m2 = 1-im
                do i=1,m
                    m2 = m2+im
                    c(m2,n) = sn*ch(i,n)
                end do
            end if
        else
            m2 = 1-im
            do i=1,m
                m2 = m2+im
                c(m2,1) = sn*c(m2,1)
            end do
            do j=2,nl,2
                m2 = 1-im
                do i=1,m
                    m2 = m2+im
                    c(m2,j) = tsn*c(m2,j)
                    c(m2,j+1) = tsnm*c(m2,j+1)
                end do
            end do

            if (modn == 0) then
                m2 = 1-im
                do i=1,m
                    m2 = m2+im
                    c(m2,n) = sn*c(m2,n)
                end do
            end if
        end if

    end subroutine mrftf1

    subroutine mradf2(m,ido,l1,cc,im1,in1,ch,im2,in2,wa1)
        !--------------------------------------------------------------
        ! Dummy arguments
        !--------------------------------------------------------------
        integer (ip) ido
        integer (ip) in1
        integer (ip) in2
        integer (ip) l1
        real (wp) cc(in1,ido,l1,2)
        real (wp) ch(in2,ido,2,l1)
        integer (ip) i
        integer (ip) ic
        integer (ip) idp2
        integer (ip) im1
        integer (ip) im2
        integer (ip) k
        integer (ip) m
        integer (ip) m1
        integer (ip) m1d
        integer (ip) m2
        integer (ip) m2s
        real (wp) wa1(ido)

        m1d = (m-1)*im1+1
        m2s = 1-im2

        do k=1,l1
            m2 = m2s
            do m1=1,m1d,im1
                m2 = m2+im2
                ch(m2,1,1,k) = cc(m1,1,k,1)+cc(m1,1,k,2)
                ch(m2,ido,2,k) = cc(m1,1,k,1)-cc(m1,1,k,2)
            end do
        end do

        if (ido < 2) then
            return
        else if (ido == 2) then
            do k=1,l1
                m2 = m2s
                do m1=1,m1d,im1
                    m2 = m2+im2
                    ch(m2,1,2,k) = -cc(m1,ido,k,2)
                    ch(m2,ido,1,k) = cc(m1,ido,k,1)
                end do
            end do
        else
            idp2 = ido+2
            do k=1,l1
                do i=3,ido,2
                    ic = idp2-i
                    m2 = m2s
                    do m1=1,m1d,im1
                        m2 = m2+im2
                        ch(m2,i,1,k) = cc(m1,i,k,1)+(wa1(i-2)*cc(m1,i,k,2)- &
                            wa1(i-1)*cc(m1,i-1,k,2))
                        ch(m2,ic,2,k) = (wa1(i-2)*cc(m1,i,k,2)-wa1(i-1)* &
                            cc(m1,i-1,k,2))-cc(m1,i,k,1)
                        ch(m2,i-1,1,k) = cc(m1,i-1,k,1)+(wa1(i-2)*cc(m1,i-1,k,2)+ &
                            wa1(i-1)*cc(m1,i,k,2))
                        ch(m2,ic-1,2,k) = cc(m1,i-1,k,1)-(wa1(i-2)*cc(m1,i-1,k,2)+ &
                            wa1(i-1)*cc(m1,i,k,2))
                    end do
                end do
            end do
            if (mod(ido,2) /= 1) then
                do k=1,l1
                    m2 = m2s
                    do m1=1,m1d,im1
                        m2 = m2+im2
                        ch(m2,1,2,k) = -cc(m1,ido,k,2)
                        ch(m2,ido,1,k) = cc(m1,ido,k,1)
                    end do
                end do
            end if
        end if

    end subroutine mradf2

    subroutine mradf3(m,ido,l1,cc,im1,in1,ch,im2,in2,wa1,wa2)

        integer (ip) ido
        integer (ip) in1
        integer (ip) in2
        integer (ip) l1

        real (wp) cc(in1,ido,l1,3)
        real (wp) ch(in2,ido,3,l1)
        integer (ip) i
        integer (ip) ic
        integer (ip) idp2
        integer (ip) im1
        integer (ip) im2
        integer (ip) k
        integer (ip) m
        integer (ip) m1
        integer (ip) m1d
        integer (ip) m2
        integer (ip) m2s
        real (wp) wa1(ido)
        real (wp) wa2(ido)
        real (wp), parameter :: TWO_PI =TWO * acos(-ONE)
        real (wp), parameter :: ARG = TWO_PI/3
        real (wp), parameter :: TAUR = cos(ARG)
        real (wp), parameter :: TAUI = sin(ARG)

        m1d = (m-1)*im1+1
        m2s = 1-im2

        do k=1,l1
            m2 = m2s
            do m1=1,m1d,im1
                m2 = m2+im2
                ch(m2,1,1,k) = cc(m1,1,k,1)+(cc(m1,1,k,2)+cc(m1,1,k,3))
                ch(m2,1,3,k) = TAUI*(cc(m1,1,k,3)-cc(m1,1,k,2))
                ch(m2,ido,2,k) = cc(m1,1,k,1)+TAUR*(cc(m1,1,k,2)+cc(m1,1,k,3))
            end do
        end do

        if (ido /= 1) then
            idp2 = ido+2
            do k=1,l1
                do i=3,ido,2
                    ic = idp2-i
                    m2 = m2s
                    do m1=1,m1d,im1
                        m2 = m2+im2
                        ch(m2,i-1,1,k) = cc(m1,i-1,k,1)+((wa1(i-2)*cc(m1,i-1,k,2)+ &
                            wa1(i-1)*cc(m1,i,k,2))+(wa2(i-2)*cc(m1,i-1,k,3)+wa2(i-1)* &
                            cc(m1,i,k,3)))

                        ch(m2,i,1,k) = cc(m1,i,k,1)+((wa1(i-2)*cc(m1,i,k,2)- &
                            wa1(i-1)*cc(m1,i-1,k,2))+(wa2(i-2)*cc(m1,i,k,3)-wa2(i-1)* &
                            cc(m1,i-1,k,3)))

                        ch(m2,i-1,3,k) = (cc(m1,i-1,k,1)+TAUR*((wa1(i-2)* &
                            cc(m1,i-1,k,2)+wa1(i-1)*cc(m1,i,k,2))+(wa2(i-2)* &
                            cc(m1,i-1,k,3)+wa2(i-1)*cc(m1,i,k,3))))+(TAUI*((wa1(i-2)* &
                            cc(m1,i,k,2)-wa1(i-1)*cc(m1,i-1,k,2))-(wa2(i-2)* &
                            cc(m1,i,k,3)-wa2(i-1)*cc(m1,i-1,k,3))))

                        ch(m2,ic-1,2,k) = (cc(m1,i-1,k,1)+TAUR*((wa1(i-2)* &
                            cc(m1,i-1,k,2)+wa1(i-1)*cc(m1,i,k,2))+(wa2(i-2)* &
                            cc(m1,i-1,k,3)+wa2(i-1)*cc(m1,i,k,3))))-(TAUI*((wa1(i-2)* &
                            cc(m1,i,k,2)-wa1(i-1)*cc(m1,i-1,k,2))-(wa2(i-2)* &
                            cc(m1,i,k,3)-wa2(i-1)*cc(m1,i-1,k,3))))

                        ch(m2,i,3,k) = (cc(m1,i,k,1)+TAUR*((wa1(i-2)*cc(m1,i,k,2)- &
                            wa1(i-1)*cc(m1,i-1,k,2))+(wa2(i-2)*cc(m1,i,k,3)-wa2(i-1)* &
                            cc(m1,i-1,k,3))))+(TAUI*((wa2(i-2)*cc(m1,i-1,k,3)+wa2(i-1)* &
                            cc(m1,i,k,3))-(wa1(i-2)*cc(m1,i-1,k,2)+wa1(i-1)* &
                            cc(m1,i,k,2))))

                        ch(m2,ic,2,k) = (TAUI*((wa2(i-2)*cc(m1,i-1,k,3)+wa2(i-1)* &
                            cc(m1,i,k,3))-(wa1(i-2)*cc(m1,i-1,k,2)+wa1(i-1)* &
                            cc(m1,i,k,2))))-(cc(m1,i,k,1)+TAUR*((wa1(i-2)*cc(m1,i,k,2)- &
                            wa1(i-1)*cc(m1,i-1,k,2))+(wa2(i-2)*cc(m1,i,k,3)-wa2(i-1)* &
                            cc(m1,i-1,k,3))))
                    end do
                end do
            end do
        end if

    end subroutine mradf3

    subroutine mradf4(m,ido,l1,cc,im1,in1,ch,im2,in2,wa1,wa2,wa3)

        integer (ip) ido
        integer (ip) in1
        integer (ip) in2
        integer (ip) l1

        real (wp) cc(in1,ido,l1,4)
        real (wp) ch(in2,ido,4,l1)
        integer (ip) i
        integer (ip) ic
        integer (ip) idp2
        integer (ip) im1
        integer (ip) im2
        integer (ip) k
        integer (ip) m
        integer (ip) m1
        integer (ip) m1d
        integer (ip) m2
        integer (ip) m2s
        real (wp) wa1(ido)
        real (wp) wa2(ido)
        real (wp) wa3(ido)
        real (wp), parameter :: HALF_SQRT2 = sqrt(TWO)/2

        m1d = (m-1)*im1+1
        m2s = 1-im2

        do k=1,l1
            m2 = m2s
            do m1=1,m1d,im1
                m2 = m2+im2
                ch(m2,1,1,k) = (cc(m1,1,k,2)+cc(m1,1,k,4)) &
                    +(cc(m1,1,k,1)+cc(m1,1,k,3))
                ch(m2,ido,4,k) = (cc(m1,1,k,1)+cc(m1,1,k,3)) &
                    -(cc(m1,1,k,2)+cc(m1,1,k,4))
                ch(m2,ido,2,k) = cc(m1,1,k,1)-cc(m1,1,k,3)
                ch(m2,1,3,k) = cc(m1,1,k,4)-cc(m1,1,k,2)
            end do
        end do

        if (ido < 2) then
            return
        else if (ido == 2) then
            do k=1,l1
                m2 = m2s
                do m1=1,m1d,im1
                    m2 = m2+im2
                    ch(m2,ido,1,k) = (HALF_SQRT2*(cc(m1,ido,k,2)-cc(m1,ido,k,4)))+ &
                        cc(m1,ido,k,1)
                    ch(m2,ido,3,k) = cc(m1,ido,k,1)-(HALF_SQRT2*(cc(m1,ido,k,2)- &
                        cc(m1,ido,k,4)))
                    ch(m2,1,2,k) = (-HALF_SQRT2*(cc(m1,ido,k,2)+cc(m1,ido,k,4)))- &
                        cc(m1,ido,k,3)
                    ch(m2,1,4,k) = (-HALF_SQRT2*(cc(m1,ido,k,2)+cc(m1,ido,k,4)))+ &
                        cc(m1,ido,k,3)
                end do
            end do
        else
            idp2 = ido+2
            do k=1,l1
                do i=3,ido,2
                    ic = idp2-i
                    m2 = m2s
                    do m1=1,m1d,im1
                        m2 = m2+im2
                        ch(m2,i-1,1,k) = ((wa1(i-2)*cc(m1,i-1,k,2)+wa1(i-1)* &
                            cc(m1,i,k,2))+(wa3(i-2)*cc(m1,i-1,k,4)+wa3(i-1)* &
                            cc(m1,i,k,4)))+(cc(m1,i-1,k,1)+(wa2(i-2)*cc(m1,i-1,k,3)+ &
                            wa2(i-1)*cc(m1,i,k,3)))

                        ch(m2,ic-1,4,k) = (cc(m1,i-1,k,1)+(wa2(i-2)*cc(m1,i-1,k,3)+ &
                            wa2(i-1)*cc(m1,i,k,3)))-((wa1(i-2)*cc(m1,i-1,k,2)+ &
                            wa1(i-1)*cc(m1,i,k,2))+(wa3(i-2)*cc(m1,i-1,k,4)+ &
                            wa3(i-1)*cc(m1,i,k,4)))

                        ch(m2,i,1,k) = ((wa1(i-2)*cc(m1,i,k,2)-wa1(i-1)* &
                            cc(m1,i-1,k,2))+(wa3(i-2)*cc(m1,i,k,4)-wa3(i-1)* &
                            cc(m1,i-1,k,4)))+(cc(m1,i,k,1)+(wa2(i-2)*cc(m1,i,k,3)- &
                            wa2(i-1)*cc(m1,i-1,k,3)))

                        ch(m2,ic,4,k) = ((wa1(i-2)*cc(m1,i,k,2)-wa1(i-1)* &
                            cc(m1,i-1,k,2))+(wa3(i-2)*cc(m1,i,k,4)-wa3(i-1)* &
                            cc(m1,i-1,k,4)))-(cc(m1,i,k,1)+(wa2(i-2)*cc(m1,i,k,3)- &
                            wa2(i-1)*cc(m1,i-1,k,3)))

                        ch(m2,i-1,3,k) = ((wa1(i-2)*cc(m1,i,k,2)-wa1(i-1)* &
                            cc(m1,i-1,k,2))-(wa3(i-2)*cc(m1,i,k,4)-wa3(i-1)* &
                            cc(m1,i-1,k,4)))+(cc(m1,i-1,k,1)-(wa2(i-2)*cc(m1,i-1,k,3)+ &
                            wa2(i-1)*cc(m1,i,k,3)))

                        ch(m2,ic-1,2,k) = (cc(m1,i-1,k,1)-(wa2(i-2)*cc(m1,i-1,k,3)+ &
                            wa2(i-1)*cc(m1,i,k,3)))-((wa1(i-2)*cc(m1,i,k,2)-wa1(i-1)* &
                            cc(m1,i-1,k,2))-(wa3(i-2)*cc(m1,i,k,4)-wa3(i-1)* &
                            cc(m1,i-1,k,4)))

                        ch(m2,i,3,k) = ((wa3(i-2)*cc(m1,i-1,k,4)+wa3(i-1)* &
                            cc(m1,i,k,4))-(wa1(i-2)*cc(m1,i-1,k,2)+wa1(i-1)* &
                            cc(m1,i,k,2)))+(cc(m1,i,k,1)-(wa2(i-2)*cc(m1,i,k,3)- &
                            wa2(i-1)*cc(m1,i-1,k,3)))

                        ch(m2,ic,2,k) = ((wa3(i-2)*cc(m1,i-1,k,4)+wa3(i-1)* &
                            cc(m1,i,k,4))-(wa1(i-2)*cc(m1,i-1,k,2)+wa1(i-1)* &
                            cc(m1,i,k,2)))-(cc(m1,i,k,1)-(wa2(i-2)*cc(m1,i,k,3)- &
                            wa2(i-1)*cc(m1,i-1,k,3)))
                    end do
                end do
            end do
            if (mod(ido,2) /= 1) then
                do k=1,l1
                    m2 = m2s
                    do m1=1,m1d,im1
                        m2 = m2+im2
                        ch(m2,ido,1,k) = (HALF_SQRT2*(cc(m1,ido,k,2)-cc(m1,ido,k,4)))+ &
                            cc(m1,ido,k,1)
                        ch(m2,ido,3,k) = cc(m1,ido,k,1)-(HALF_SQRT2*(cc(m1,ido,k,2)- &
                            cc(m1,ido,k,4)))
                        ch(m2,1,2,k) = (-HALF_SQRT2*(cc(m1,ido,k,2)+cc(m1,ido,k,4)))- &
                            cc(m1,ido,k,3)
                        ch(m2,1,4,k) = (-HALF_SQRT2*(cc(m1,ido,k,2)+cc(m1,ido,k,4)))+ &
                            cc(m1,ido,k,3)
                    end do
                end do
            end if
        end if

    end subroutine mradf4

    subroutine mradf5(m,ido,l1,cc,im1,in1,ch,im2,in2,wa1,wa2,wa3,wa4)

        integer (ip) ido
        integer (ip) in1
        integer (ip) in2
        integer (ip) l1

        real (wp) cc(in1,ido,l1,5)
        real (wp) ch(in2,ido,5,l1)
        integer (ip) i
        integer (ip) ic
        integer (ip) idp2
        integer (ip) im1
        integer (ip) im2
        integer (ip) k
        integer (ip) m
        integer (ip) m1
        integer (ip) m1d
        integer (ip) m2
        integer (ip) m2s
        real (wp) wa1(ido)
        real (wp) wa2(ido)
        real (wp) wa3(ido)
        real (wp) wa4(ido)
        real (wp), parameter :: TWO_PI = TWO * acos(-ONE)
        real (wp), parameter :: ARG = TWO_PI/5
        real (wp), parameter :: TR11 = cos(ARG)
        real (wp), parameter :: TI11 = sin(ARG)
        real (wp), parameter :: TR12 = cos(TWO*ARG)
        real (wp), parameter :: TI12 = sin(TWO*ARG)

        m1d = (m-1)*im1+1
        m2s = 1-im2

        do k=1,l1
            m2 = m2s
            do m1=1,m1d,im1
                m2 = m2+im2
                ch(m2,1,1,k) = cc(m1,1,k,1)+(cc(m1,1,k,5)+cc(m1,1,k,2))+ &
                    (cc(m1,1,k,4)+cc(m1,1,k,3))
                ch(m2,ido,2,k) = cc(m1,1,k,1)+TR11*(cc(m1,1,k,5)+cc(m1,1,k,2))+ &
                    TR12*(cc(m1,1,k,4)+cc(m1,1,k,3))
                ch(m2,1,3,k) = TI11*(cc(m1,1,k,5)-cc(m1,1,k,2))+TI12* &
                    (cc(m1,1,k,4)-cc(m1,1,k,3))
                ch(m2,ido,4,k) = cc(m1,1,k,1)+TR12*(cc(m1,1,k,5)+cc(m1,1,k,2))+ &
                    TR11*(cc(m1,1,k,4)+cc(m1,1,k,3))
                ch(m2,1,5,k) = TI12*(cc(m1,1,k,5)-cc(m1,1,k,2))-TI11* &
                    (cc(m1,1,k,4)-cc(m1,1,k,3))
            end do
        end do

        if (ido /= 1) then
            idp2 = ido+2
            do k=1,l1
                do i=3,ido,2
                    ic = idp2-i
                    m2 = m2s
                    do m1=1,m1d,im1
                        m2 = m2+im2

                        ch(m2,i-1,1,k) = cc(m1,i-1,k,1)+((wa1(i-2)*cc(m1,i-1,k,2)+ &
                            wa1(i-1)*cc(m1,i,k,2))+(wa4(i-2)*cc(m1,i-1,k,5)+wa4(i-1)* &
                            cc(m1,i,k,5)))+((wa2(i-2)*cc(m1,i-1,k,3)+wa2(i-1)* &
                            cc(m1,i,k,3))+(wa3(i-2)*cc(m1,i-1,k,4)+ &
                            wa3(i-1)*cc(m1,i,k,4)))

                        ch(m2,i,1,k) = cc(m1,i,k,1)+((wa1(i-2)*cc(m1,i,k,2)- &
                            wa1(i-1)*cc(m1,i-1,k,2))+(wa4(i-2)*cc(m1,i,k,5)-wa4(i-1)* &
                            cc(m1,i-1,k,5)))+((wa2(i-2)*cc(m1,i,k,3)-wa2(i-1)* &
                            cc(m1,i-1,k,3))+(wa3(i-2)*cc(m1,i,k,4)-wa3(i-1)* &
                            cc(m1,i-1,k,4)))

                        ch(m2,i-1,3,k) = cc(m1,i-1,k,1)+TR11* &
                            ( wa1(i-2)*cc(m1,i-1,k,2)+wa1(i-1)*cc(m1,i,k,2) &
                            +wa4(i-2)*cc(m1,i-1,k,5)+wa4(i-1)*cc(m1,i,k,5))+TR12* &
                            ( wa2(i-2)*cc(m1,i-1,k,3)+wa2(i-1)*cc(m1,i,k,3) &
                            +wa3(i-2)*cc(m1,i-1,k,4)+wa3(i-1)*cc(m1,i,k,4))+TI11* &
                            ( wa1(i-2)*cc(m1,i,k,2)-wa1(i-1)*cc(m1,i-1,k,2) &
                            -(wa4(i-2)*cc(m1,i,k,5)-wa4(i-1)*cc(m1,i-1,k,5)))+TI12* &
                            ( wa2(i-2)*cc(m1,i,k,3)-wa2(i-1)*cc(m1,i-1,k,3) &
                            -(wa3(i-2)*cc(m1,i,k,4)-wa3(i-1)*cc(m1,i-1,k,4)))

                        ch(m2,ic-1,2,k) = cc(m1,i-1,k,1)+TR11* &
                            ( wa1(i-2)*cc(m1,i-1,k,2)+wa1(i-1)*cc(m1,i,k,2) &
                            +wa4(i-2)*cc(m1,i-1,k,5)+wa4(i-1)*cc(m1,i,k,5))+TR12* &
                            ( wa2(i-2)*cc(m1,i-1,k,3)+wa2(i-1)*cc(m1,i,k,3) &
                            +wa3(i-2)*cc(m1,i-1,k,4)+wa3(i-1)*cc(m1,i,k,4))-(TI11* &
                            ( wa1(i-2)*cc(m1,i,k,2)-wa1(i-1)*cc(m1,i-1,k,2) &
                            -(wa4(i-2)*cc(m1,i,k,5)-wa4(i-1)*cc(m1,i-1,k,5)))+TI12* &
                            ( wa2(i-2)*cc(m1,i,k,3)-wa2(i-1)*cc(m1,i-1,k,3) &
                            -(wa3(i-2)*cc(m1,i,k,4)-wa3(i-1)*cc(m1,i-1,k,4))))

                        ch(m2,i,3,k) = (cc(m1,i,k,1)+TR11*((wa1(i-2)*cc(m1,i,k,2)- &
                            wa1(i-1)*cc(m1,i-1,k,2))+(wa4(i-2)*cc(m1,i,k,5)-wa4(i-1)* &
                            cc(m1,i-1,k,5)))+TR12*((wa2(i-2)*cc(m1,i,k,3)-wa2(i-1)* &
                            cc(m1,i-1,k,3))+(wa3(i-2)*cc(m1,i,k,4)-wa3(i-1)* &
                            cc(m1,i-1,k,4))))+(TI11*((wa4(i-2)*cc(m1,i-1,k,5)+ &
                            wa4(i-1)*cc(m1,i,k,5))-(wa1(i-2)*cc(m1,i-1,k,2)+wa1(i-1)* &
                            cc(m1,i,k,2)))+TI12*((wa3(i-2)*cc(m1,i-1,k,4)+wa3(i-1)* &
                            cc(m1,i,k,4))-(wa2(i-2)*cc(m1,i-1,k,3)+wa2(i-1)* &
                            cc(m1,i,k,3))))

                        ch(m2,ic,2,k) = (TI11*((wa4(i-2)*cc(m1,i-1,k,5)+wa4(i-1)* &
                            cc(m1,i,k,5))-(wa1(i-2)*cc(m1,i-1,k,2)+wa1(i-1)* &
                            cc(m1,i,k,2)))+TI12*((wa3(i-2)*cc(m1,i-1,k,4)+wa3(i-1)* &
                            cc(m1,i,k,4))-(wa2(i-2)*cc(m1,i-1,k,3)+wa2(i-1)* &
                            cc(m1,i,k,3))))-(cc(m1,i,k,1)+TR11*((wa1(i-2)*cc(m1,i,k,2)- &
                            wa1(i-1)*cc(m1,i-1,k,2))+(wa4(i-2)*cc(m1,i,k,5)-wa4(i-1)* &
                            cc(m1,i-1,k,5)))+TR12*((wa2(i-2)*cc(m1,i,k,3)-wa2(i-1)* &
                            cc(m1,i-1,k,3))+(wa3(i-2)*cc(m1,i,k,4)-wa3(i-1)* &
                            cc(m1,i-1,k,4))))

                        ch(m2,i-1,5,k) = (cc(m1,i-1,k,1)+TR12*((wa1(i-2)* &
                            cc(m1,i-1,k,2)+wa1(i-1)*cc(m1,i,k,2))+(wa4(i-2)* &
                            cc(m1,i-1,k,5)+wa4(i-1)*cc(m1,i,k,5)))+TR11*((wa2(i-2)* &
                            cc(m1,i-1,k,3)+wa2(i-1)*cc(m1,i,k,3))+(wa3(i-2)* &
                            cc(m1,i-1,k,4)+wa3(i-1)*cc(m1,i,k,4))))+(TI12*((wa1(i-2)* &
                            cc(m1,i,k,2)-wa1(i-1)*cc(m1,i-1,k,2))-(wa4(i-2)* &
                            cc(m1,i,k,5)-wa4(i-1)*cc(m1,i-1,k,5)))-TI11*((wa2(i-2)* &
                            cc(m1,i,k,3)-wa2(i-1)*cc(m1,i-1,k,3))-(wa3(i-2)* &
                            cc(m1,i,k,4)-wa3(i-1)*cc(m1,i-1,k,4))))

                        ch(m2,ic-1,4,k) = (cc(m1,i-1,k,1)+TR12*((wa1(i-2)* &
                            cc(m1,i-1,k,2)+wa1(i-1)*cc(m1,i,k,2))+(wa4(i-2)* &
                            cc(m1,i-1,k,5)+wa4(i-1)*cc(m1,i,k,5)))+TR11*((wa2(i-2)* &
                            cc(m1,i-1,k,3)+wa2(i-1)*cc(m1,i,k,3))+(wa3(i-2)* &
                            cc(m1,i-1,k,4)+wa3(i-1)*cc(m1,i,k,4))))-(TI12*((wa1(i-2)* &
                            cc(m1,i,k,2)-wa1(i-1)*cc(m1,i-1,k,2))-(wa4(i-2)* &
                            cc(m1,i,k,5)-wa4(i-1)*cc(m1,i-1,k,5)))-TI11*((wa2(i-2)* &
                            cc(m1,i,k,3)-wa2(i-1)*cc(m1,i-1,k,3))-(wa3(i-2)* &
                            cc(m1,i,k,4)-wa3(i-1)*cc(m1,i-1,k,4))))

                        ch(m2,i,5,k) = (cc(m1,i,k,1)+TR12*((wa1(i-2)*cc(m1,i,k,2)- &
                            wa1(i-1)*cc(m1,i-1,k,2))+(wa4(i-2)*cc(m1,i,k,5)-wa4(i-1)* &
                            cc(m1,i-1,k,5)))+TR11*((wa2(i-2)*cc(m1,i,k,3)-wa2(i-1)* &
                            cc(m1,i-1,k,3))+(wa3(i-2)*cc(m1,i,k,4)-wa3(i-1)* &
                            cc(m1,i-1,k,4))))+(TI12*((wa4(i-2)*cc(m1,i-1,k,5)+ &
                            wa4(i-1)*cc(m1,i,k,5))-(wa1(i-2)*cc(m1,i-1,k,2)+wa1(i-1)* &
                            cc(m1,i,k,2)))-TI11*((wa3(i-2)*cc(m1,i-1,k,4)+wa3(i-1)* &
                            cc(m1,i,k,4))-(wa2(i-2)*cc(m1,i-1,k,3)+wa2(i-1)* &
                            cc(m1,i,k,3))))

                        ch(m2,ic,4,k) = (TI12*((wa4(i-2)*cc(m1,i-1,k,5)+wa4(i-1)* &
                            cc(m1,i,k,5))-(wa1(i-2)*cc(m1,i-1,k,2)+wa1(i-1)* &
                            cc(m1,i,k,2)))-TI11*((wa3(i-2)*cc(m1,i-1,k,4)+wa3(i-1)* &
                            cc(m1,i,k,4))-(wa2(i-2)*cc(m1,i-1,k,3)+wa2(i-1)* &
                            cc(m1,i,k,3))))-(cc(m1,i,k,1)+TR12*((wa1(i-2)*cc(m1,i,k,2)- &
                            wa1(i-1)*cc(m1,i-1,k,2))+(wa4(i-2)*cc(m1,i,k,5)-wa4(i-1)* &
                            cc(m1,i-1,k,5)))+TR11*((wa2(i-2)*cc(m1,i,k,3)-wa2(i-1)* &
                            cc(m1,i-1,k,3))+(wa3(i-2)*cc(m1,i,k,4)-wa3(i-1)* &
                            cc(m1,i-1,k,4))))
                    end do
                end do
            end do
        end if

    end subroutine mradf5

    subroutine mradfg(m,ido,iip,l1,idl1,cc,c1,c2,im1,in1,ch,ch2,im2,in2,wa)

        integer (ip) idl1
        integer (ip) ido
        integer (ip) in1
        integer (ip) in2
        integer (ip) iip
        integer (ip) l1

        real (wp) ai1
        real (wp) ai2
        real (wp) ar1
        real (wp) ar1h
        real (wp) ar2
        real (wp) ar2h
        real (wp) arg
        real (wp) c1(in1,ido,l1,iip)
        real (wp) c2(in1,idl1,iip)
        real (wp) cc(in1,ido,iip,l1)
        real (wp) ch(in2,ido,l1,iip)
        real (wp) ch2(in2,idl1,iip)
        real (wp) dc2
        real (wp) dcp
        real (wp) ds2
        real (wp) dsp
        integer (ip) i
        integer (ip) ic
        integer (ip) idij
        integer (ip) idp2
        integer (ip) ik
        integer (ip) im1
        integer (ip) im2
        integer (ip) iipp2
        integer (ip) iipph
        integer (ip) is
        integer (ip) j
        integer (ip) j2
        integer (ip) jc
        integer (ip) k
        integer (ip) l
        integer (ip) lc
        integer (ip) m
        integer (ip) m1
        integer (ip) m1d
        integer (ip) m2
        integer (ip) m2s
        integer (ip) nbd
        real (wp), parameter :: TWO_PI= TWO * acos(-ONE)
        real (wp) wa(ido)

        m1d = (m-1)*im1+1
        m2s = 1-im2
        arg = TWO_PI / iip
        dcp = cos(arg)
        dsp = sin(arg)
        iipph = (iip+1)/2
        iipp2 = iip+2
        idp2 = ido+2
        nbd = (ido-1)/2

        if (ido /= 1) then

            do ik=1,idl1
                m2 = m2s
                do m1=1,m1d,im1
                    m2 = m2+im2
                    ch2(m2,ik,1) = c2(m1,ik,1)
                end do
            end do

            do j=2,iip
                do k=1,l1
                    m2 = m2s
                    do m1=1,m1d,im1
                        m2 = m2+im2
                        ch(m2,1,k,j) = c1(m1,1,k,j)
                    end do
                end do
            end do

            if (nbd <= l1) then
                is = -ido
                do j=2,iip
                    is = is+ido
                    idij = is
                    do i=3,ido,2
                        idij = idij+2
                        do k=1,l1
                            m2 = m2s
                            do m1=1,m1d,im1
                                m2 = m2+im2
                                ch(m2,i-1,k,j) = wa(idij-1)*c1(m1,i-1,k,j)+wa(idij)*c1(m1,i,k,j)
                                ch(m2,i,k,j) = wa(idij-1)*c1(m1,i,k,j)-wa(idij)*c1(m1,i-1,k,j)
                            end do
                        end do
                    end do
                end do
            else
                is = -ido
                do j=2,iip
                    is = is+ido
                    do k=1,l1
                        idij = is
                        do i=3,ido,2
                            idij = idij+2
                            m2 = m2s
                            do m1=1,m1d,im1
                                m2 = m2+im2
                                ch(m2,i-1,k,j) = wa(idij-1)*c1(m1,i-1,k,j)+wa(idij)*c1(m1,i,k,j)
                                ch(m2,i,k,j) = wa(idij-1)*c1(m1,i,k,j)-wa(idij)*c1(m1,i-1,k,j)
                            end do
                        end do
                    end do
                end do
            end if

            if (l1 <= nbd) then
                do j=2,iipph
                    jc = iipp2-j
                    do k=1,l1
                        do i=3,ido,2
                            m2 = m2s
                            do m1=1,m1d,im1
                                m2 = m2+im2
                                c1(m1,i-1,k,j) = ch(m2,i-1,k,j)+ch(m2,i-1,k,jc)
                                c1(m1,i-1,k,jc) = ch(m2,i,k,j)-ch(m2,i,k,jc)
                                c1(m1,i,k,j) = ch(m2,i,k,j)+ch(m2,i,k,jc)
                                c1(m1,i,k,jc) = ch(m2,i-1,k,jc)-ch(m2,i-1,k,j)
                            end do
                        end do
                    end do
                end do
            else
                do j=2,iipph
                    jc = iipp2-j
                    do i=3,ido,2
                        do k=1,l1
                            m2 = m2s
                            do m1=1,m1d,im1
                                m2 = m2+im2
                                c1(m1,i-1,k,j) = ch(m2,i-1,k,j)+ch(m2,i-1,k,jc)
                                c1(m1,i-1,k,jc) = ch(m2,i,k,j)-ch(m2,i,k,jc)
                                c1(m1,i,k,j) = ch(m2,i,k,j)+ch(m2,i,k,jc)
                                c1(m1,i,k,jc) = ch(m2,i-1,k,jc)-ch(m2,i-1,k,j)
                            end do
                        end do
                    end do
                end do
            end if
        else
            do ik=1,idl1
                m2 = m2s
                do m1=1,m1d,im1
                    m2 = m2+im2
                    c2(m1,ik,1) = ch2(m2,ik,1)
                end do
            end do
        end if
        do j=2,iipph
            jc = iipp2-j
            do k=1,l1
                m2 = m2s
                do m1=1,m1d,im1
                    m2 = m2+im2
                    c1(m1,1,k,j) = ch(m2,1,k,j)+ch(m2,1,k,jc)
                    c1(m1,1,k,jc) = ch(m2,1,k,jc)-ch(m2,1,k,j)
                end do
            end do
        end do

        ar1 = ONE
        ai1 = ZERO
        do l=2,iipph
            lc = iipp2-l
            ar1h = dcp*ar1-dsp*ai1
            ai1 = dcp*ai1+dsp*ar1
            ar1 = ar1h
            do ik=1,idl1
                m2 = m2s
                do m1=1,m1d,im1
                    m2 = m2+im2
                    ch2(m2,ik,l) = c2(m1,ik,1)+ar1*c2(m1,ik,2)
                    ch2(m2,ik,lc) = ai1*c2(m1,ik,iip)
                end do
            end do
            dc2 = ar1
            ds2 = ai1
            ar2 = ar1
            ai2 = ai1
            do j=3,iipph
                jc = iipp2-j
                ar2h = dc2*ar2-ds2*ai2
                ai2 = dc2*ai2+ds2*ar2
                ar2 = ar2h
                do ik=1,idl1
                    m2 = m2s
                    do m1=1,m1d,im1
                        m2 = m2+im2
                        ch2(m2,ik,l) = ch2(m2,ik,l)+ar2*c2(m1,ik,j)
                        ch2(m2,ik,lc) = ch2(m2,ik,lc)+ai2*c2(m1,ik,jc)
                    end do
                end do
            end do
        end do
        do j=2,iipph
            do ik=1,idl1
                m2 = m2s
                do m1=1,m1d,im1
                    m2 = m2+im2
                    ch2(m2,ik,1) = ch2(m2,ik,1)+c2(m1,ik,j)
                end do
            end do
        end do

        if (ido >= l1) then
            do k=1,l1
                do i=1,ido
                    m2 = m2s
                    do m1=1,m1d,im1
                        m2 = m2+im2
                        cc(m1,i,1,k) = ch(m2,i,k,1)
                    end do
                end do
            end do
        else
            do i=1,ido
                do k=1,l1
                    m2 = m2s
                    do m1=1,m1d,im1
                        m2 = m2+im2
                        cc(m1,i,1,k) = ch(m2,i,k,1)
                    end do
                end do
            end do
        end if

        do j=2,iipph
            jc = iipp2-j
            j2 = j+j
            do k=1,l1
                m2 = m2s
                do m1=1,m1d,im1
                    m2 = m2+im2
                    cc(m1,ido,j2-2,k) = ch(m2,1,k,j)
                    cc(m1,1,j2-1,k) = ch(m2,1,k,jc)
                end do
            end do
        end do
        if (ido /= 1) then
            if (l1 <= nbd) then
                do j=2,iipph
                    jc = iipp2-j
                    j2 = j+j
                    do k=1,l1
                        do i=3,ido,2
                            ic = idp2-i
                            m2 = m2s
                            do m1=1,m1d,im1
                                m2 = m2+im2
                                cc(m1,i-1,j2-1,k) = ch(m2,i-1,k,j)+ch(m2,i-1,k,jc)
                                cc(m1,ic-1,j2-2,k) = ch(m2,i-1,k,j)-ch(m2,i-1,k,jc)
                                cc(m1,i,j2-1,k) = ch(m2,i,k,j)+ch(m2,i,k,jc)
                                cc(m1,ic,j2-2,k) = ch(m2,i,k,jc)-ch(m2,i,k,j)
                            end do
                        end do
                    end do
                end do
            else
                do j=2,iipph
                    jc = iipp2-j
                    j2 = j+j
                    do i=3,ido,2
                        ic = idp2-i
                        do k=1,l1
                            m2 = m2s
                            do m1=1,m1d,im1
                                m2 = m2+im2
                                cc(m1,i-1,j2-1,k) = ch(m2,i-1,k,j)+ch(m2,i-1,k,jc)
                                cc(m1,ic-1,j2-2,k) = ch(m2,i-1,k,j)-ch(m2,i-1,k,jc)
                                cc(m1,i,j2-1,k) = ch(m2,i,k,j)+ch(m2,i,k,jc)
                                cc(m1,ic,j2-2,k) = ch(m2,i,k,jc)-ch(m2,i,k,j)
                            end do
                        end do
                    end do
                end do
            end if
        end if

    end subroutine mradfg

end submodule multiple_real_forward


module datastructmult
  !====================================================================
  ! Data structures for multigrid method
  ! Marline I. Silva - Sept 2014
  !=====================================================================

 !Use global constants and kinds
  use constants, only: i4, r8

  use datastruct, only: &
    grid_structure

  type cell_relation
  !----------------------------------------------------
  ! Cellwise node indexes relating 2 different grid levels
  !----------------------------------------------------

     !two indices coarse mesh cell for localization index cell
     !fine mesh
     integer(i4),dimension(1:2)::cel

     !index cell fine mesh between two cells
     integer(i4)::celm

     !index cell coarse mesh and fine mesh
     integer(i4)::cmg

     !index cell fine mesh contained in the cell coarse mesh
     integer(i4)::cmf

  end type cell_relation

  type grid_relation
  !--------------------------------------------------------
  !  Full mesh node indexes relation between 2 grid levels
  !--------------------------------------------------------
     !list of nodes fine mesh not contained in coarse mesh
     type(cell_relation), allocatable::indmf(:)

     !list of nodes cell fine mesh
     type(cell_relation), allocatable::cf(:)

     !list of nodes cell coarse mesh
     type(cell_relation), allocatable::cng(:)

     !nodes cell coarse mesh
     integer(i4), allocatable::cg(:)

  end type grid_relation

  type multimesh
    !-------------------------------------------
    ! Hierarchy of grids with several levels
    !-------------------------------------------
     !Lista de malhas
     type(grid_structure), allocatable::mesh(:)

     !Fine mesh
     type(grid_relation),allocatable::mf(:)

     !Coarser mesh
     type(grid_relation),allocatable::mg(:)

  end type multimesh

  type multisol2
  !----------------------------------------
  ! Function vectors for solution and residual
  !------------------------------------------
     !function value
     real(r8),allocatable::valf(:)

     !Residue value
     real(r8),allocatable::resf(:)

  end type multisol2

  type multisol
    !------------------------------------
    ! Solution for each grid level
    !-----------------------------------
     !value at each level
     type(multisol2), allocatable::solm(:)

   end type multisol

  type interpolable_meshes
     ! Values array, ordered in the same sequence as the
     !   valeus function

     real (r8), allocatable  :: f(:)
  end type interpolable_meshes

end module datastructmult


!> \file regul_toolsadj.f90
!! \brief routines to compute the gradient of a discretized (finite differences) function
!! @author Innocent Souopgui
!! @version 1.0
!<
MODULE regul_toolsadj
  USE general_constant
  USE regul_tools
  USE debug_tools
IMPLICIT NONE

  !> \brief interface for gradient approximation
  INTERFACE gradientAdj
    MODULE PROCEDURE gradient_cs_1dAdj!constant spacing
    MODULE PROCEDURE gradient_vs_1dAdj!variable spacing
    MODULE PROCEDURE gradient_cs_2dAdj!constant spacing
    !MODULE PROCEDURE gradient_vs_2dAdj!variable spacing
    !MODULE PROCEDURE gradient_cs_3dAdj!constant spacing
    !MODULE PROCEDURE gradient_vs_3dAdj!variable spacing
  END INTERFACE gradientAdj

  !> \brief interface for gradient approximation using centered differences
  INTERFACE gradient_centeredAdj
    MODULE PROCEDURE gradient_ccs_1dAdj
    !MODULE PROCEDURE gradient_cvs_1dAdj
    MODULE PROCEDURE gradient_ccs_2dAdj
    !MODULE PROCEDURE gradient_cvs_2dAdj
    !MODULE PROCEDURE gradient_ccs_3dAdj
    !MODULE PROCEDURE gradient_cvs_3dAdj
  END INTERFACE gradient_centeredAdj

  !> \brief interface for gradient approximation using forward differences
  INTERFACE gradient_forwardAdj
    MODULE PROCEDURE gradient_fcs_1dAdj
    MODULE PROCEDURE gradient_fvs_1dAdj
    MODULE PROCEDURE gradient_fcs_2dAdj
    !MODULE PROCEDURE gradient_fvs_2dAdj
    !MODULE PROCEDURE gradient_fcs_3dAdj
    !MODULE PROCEDURE gradient_fvs_3dAdj
  END INTERFACE gradient_forwardAdj

  !> \brief interface for gradient approximation using backward differences
  INTERFACE gradient_backwardAdj
    MODULE PROCEDURE gradient_bcs_1dAdj
    MODULE PROCEDURE gradient_bvs_1dAdj
    MODULE PROCEDURE gradient_bcs_2dAdj
    !MODULE PROCEDURE gradient_bvs_2dAdj
    !MODULE PROCEDURE gradient_bcs_3dAdj
    !MODULE PROCEDURE gradient_bvs_3dAdj
  END INTERFACE gradient_backwardAdj

  !> \brief interface for the adjoint of geostrophic_wind
  INTERFACE geostrophic_windAdj
    MODULE PROCEDURE geostrophic_wind_cgridAdj !>"staggered" Arakawa C-grid
  END INTERFACE geostrophic_windAdj

  !> \brief interface for gradient regularization
  INTERFACE grad_regulAdj
    MODULE PROCEDURE grad_regul_cs_1dAdj!constant spacing
    MODULE PROCEDURE grad_regul_cs_1d_defaultAdj!constant spacing
    MODULE PROCEDURE grad_regul_vs_1dAdj!variable spacing
    MODULE PROCEDURE grad_regul_cs_2dAdj!constant spacing
    MODULE PROCEDURE grad_regul_cs_v2dAdj
    MODULE PROCEDURE grad_regul_cs_2d_defaultAdj!constant spacing
    MODULE PROCEDURE grad_regul_cs_v2d_defaultAdj
    !MODULE PROCEDURE grad_regul_vs_2dAdj!variable spacing
    !MODULE PROCEDURE grad_regul_cs_3dAdj!constant spacing
    !MODULE PROCEDURE grad_regul_cs_3d_defaultAdj!constant spacing
    !MODULE PROCEDURE grad_regul_vs_3dAdj!variable spacing
  END INTERFACE grad_regulAdj

  INTERFACE tikhonov_regulAdj
    MODULE PROCEDURE tikhonov_regul_1dAdj
    MODULE PROCEDURE tikhonov_regul_2dAdj
  END INTERFACE tikhonov_regulAdj

  INTERFACE geostrophic_regulAdj
    !MODULE PROCEDURE tikhonov_regul_1d
    MODULE PROCEDURE geostrophic_regul_cgridAdj
  END INTERFACE geostrophic_regulAdj

  !> \brief interface for square L2 norm
  INTERFACE square_L2_normAdj
    MODULE PROCEDURE square_L2_norm_1dAdj
    MODULE PROCEDURE square_L2_norm_2dAdj
    !MODULE PROCEDURE square_L2_norm_3dAdj
  END INTERFACE square_L2_normAdj

CONTAINS

  SUBROUTINE square_L2_norm_1dAdj(rda_f, rda_fad, rl_l2ad)
    REAL(KIND=cp), DIMENSION(:), INTENT(IN)    :: rda_f!!scalar field
    REAL(KIND=cp), DIMENSION(:), INTENT(INOUT) :: rda_fad!!adjoint scalar field
    REAL(KIND=cp)              , INTENT(INOUT) :: rl_l2ad

    rda_fad = rda_fad + rl_l2ad * rda_f
    rl_l2ad = 0.0_dp
  END SUBROUTINE square_L2_norm_1dAdj

  SUBROUTINE square_L2_norm_2dAdj(rda_f, rda_fad, rl_l2ad)
    REAL(KIND=cp), DIMENSION(:, :), INTENT(IN)    :: rda_f!!scalar field
    REAL(KIND=cp), DIMENSION(:, :), INTENT(INOUT) :: rda_fad!!adjoint scalar field
    REAL(KIND=cp)                 , INTENT(INOUT) :: rl_l2ad

    rda_fad = rda_fad + rl_l2ad * rda_f
    rl_l2ad = 0.0_dp
  END SUBROUTINE square_L2_norm_2dAdj

  !> \brief Computes the gradient of a scalar function of one variable, constant spacing grid
  !<
  SUBROUTINE gradient_cs_1dAdj(rda_fad, rda_dfad, method, rd_dx)
    REAL(KIND=cp), DIMENSION(:), INTENT(INOUT) :: rda_fad
    REAL(KIND=cp), DIMENSION(:), INTENT(INOUT) :: rda_dfad
    INTEGER,                     INTENT(IN)    :: method
    REAL(KIND=cp), OPTIONAL,     INTENT(IN)    :: rd_dx !! dxspace step
    !local variables
    REAL(KIND=cp) :: rl_dx

    rl_dx = disc_step(rd_dx)
    SELECT CASE (method)
      CASE(BACKWARD)
        CALL gradient_bcs_1dAdj(rda_fad, rda_dfad, rl_dx)
      CASE(FORWARD)
        CALL gradient_fcs_1dAdj(rda_fad, rda_dfad, rl_dx)
      CASE(CENTERED)
        CALL gradient_ccs_1dAdj(rda_fad, rda_dfad, rl_dx)
    END SELECT
  END SUBROUTINE gradient_cs_1dAdj

  !> \brief Computes the gradient of a scalar function of two variables, constant spacing grid
  !<
  SUBROUTINE gradient_cs_2dAdj(rda_fad, rda_fxad, rda_fyad, method, rd_dx, rd_dy)
    REAL(KIND=cp), DIMENSION(:, :), INTENT(INOUT) :: rda_fad!!scalar vector fieldwhich gradient is to be computed
    REAL(KIND=cp), DIMENSION(:, :), INTENT(INOUT) :: rda_fxad, rda_fyad!!x (resp. y) component of the gradient
    INTEGER,                        INTENT(IN)    :: method
    REAL(KIND=cp), OPTIONAL,        INTENT(IN)    :: rd_dx, rd_dy!! x(resp. y) space step
    !local variables
    REAL(KIND=cp)                                 :: rl_dx, rl_dy!! x(resp. y) space step

    rl_dx = disc_step(rd_dx)
    rl_dy = disc_step(rd_dy)
    SELECT CASE (method)
      CASE(BACKWARD)
        CALL gradient_bcs_2dAdj(rda_fad, rda_fxad, rda_fyad, rl_dx, rl_dy)
      CASE(FORWARD)
        CALL gradient_fcs_2dAdj(rda_fad, rda_fxad, rda_fyad, rl_dx, rl_dy)
      CASE(CENTERED)
        CALL gradient_ccs_2dAdj(rda_fad, rda_fxad, rda_fyad, rl_dx, rl_dy)
    END SELECT
  END SUBROUTINE gradient_cs_2dAdj

  !> \brief Computes the gradient of a scalar function of one variable, variable spacing grid
  !! \param[in] rda_fad function whose the gradient is required
  !! \param[out] rda_dfad gradient
  !! \param[in] rda_x discretization step in the first direction
  !! \param[in] method method used for computation
  !<
  SUBROUTINE gradient_vs_1dAdj(rda_fad, rda_dfad, method, rda_x)
    REAL(KIND=cp), DIMENSION(:), INTENT(INOUT) :: rda_fad
    REAL(KIND=cp), DIMENSION(:), INTENT(INOUT) :: rda_dfad
    REAL(KIND=cp), DIMENSION(:), INTENT(IN)    :: rda_x
    INTEGER,                     INTENT(IN)  :: method

    SELECT CASE (method)
      CASE(BACKWARD)
        CALL gradient_bvs_1dAdj(rda_fad, rda_dfad, rda_x)
      CASE(FORWARD)
        CALL gradient_fvs_1dAdj(rda_fad, rda_dfad, rda_x)
      CASE(CENTERED)
        CALL stop_program('In gradient_vs_1d: the centered approximation is not yet implemented for variable spacing grid')
        !CALL gradient_cvs_1dAdj(rda_fad, rda_dfad, rda_x)
    END SELECT
  END SUBROUTINE gradient_vs_1dAdj

  SUBROUTINE gradient_fcs_1dAdj(rda_fad, rda_dfad, rd_dx)
    REAL(KIND=cp), DIMENSION(:), INTENT(INOUT) :: rda_fad !!scalar vector fieldwhich gradient is to be computed
    REAL(KIND=cp), DIMENSION(:), INTENT(INOUT) :: rda_dfad!!x (resp. y) component of the gradient
    REAL(KIND=cp),                  INTENT(IN)    :: rd_dx   !! x(resp. y) space step
    INTEGER :: n

    n = SIZE(rda_fad)

    !right boundary
    rda_fad(n  ) = rda_fad(n  ) + rda_dfad(n)/rd_dx
    rda_fad(n-1) = rda_fad(n-1) - rda_dfad(n)/rd_dx
    rda_dfad(n ) = 0.0_dp
    !
    rda_fad (2:n  ) = rda_fad(2:n  ) + rda_dfad(1:n-1)/rd_dx
    rda_fad (1:n-1) = rda_fad(1:n-1) - rda_dfad(1:n-1)/rd_dx
    rda_dfad(1:n-1) = 0.0_dp
  END SUBROUTINE gradient_fcs_1dAdj

  SUBROUTINE gradient_fvs_1dAdj(rda_fad, rda_dfad, rda_x)
    REAL(KIND=cp), DIMENSION(:), INTENT(INOUT) :: rda_fad !!scalar vector fieldwhich gradient is to be computed
    REAL(KIND=cp), DIMENSION(:), INTENT(INOUT) :: rda_dfad!!x (resp. y) component of the gradient
    REAL(KIND=cp), DIMENSION(:), INTENT(IN)    :: rda_x   !! x(resp. y) space step
    INTEGER :: n

    n = SIZE(rda_fad)

    !right boundary
    rda_fad (n  ) = rda_fad(n  ) + rda_dfad(n)/( rda_x(n  )-rda_x(n-1  ) )
    rda_fad (n-1) = rda_fad(n-1) - rda_dfad(n)/( rda_x(n  )-rda_x(n-1  ) )
    rda_dfad(n  ) = 0.0_dp
    !
    rda_fad (2:n  ) = rda_fad(2:n  ) + rda_dfad(1:n-1)/( rda_x(2:n)-rda_x(1:n-1) )
    rda_fad (1:n-1) = rda_fad(1:n-1) - rda_dfad(1:n-1)/( rda_x(2:n)-rda_x(1:n-1) )
    rda_dfad(1:n-1) = 0.0_dp
  END SUBROUTINE gradient_fvs_1dAdj

  SUBROUTINE gradient_fcs_2dAdj(rda_fad, rda_fxad, rda_fyad, rd_dx, rd_dy)
    REAL(KIND=cp), DIMENSION(:, :), INTENT(INOUT) :: rda_fad!!scalar vector fieldwhich gradient is to be computed
    REAL(KIND=cp), DIMENSION(:, :), INTENT(INOUT) :: rda_fxad, rda_fyad!!x (resp. y) component of the gradient
    REAL(KIND=cp),                  INTENT(IN)    :: rd_dx, rd_dy!! x(resp. y) space step
    INTEGER :: nx, ny

    nx = SIZE(rda_fad, 1)
    ny = SIZE(rda_fad, 2)

    !y component
    !upper boundary
    rda_fad (:, ny  ) = rda_fad(:, ny  ) + rda_fyad(:, ny)/rd_dy
    rda_fad (:, ny-1) = rda_fad(:, ny-1) - rda_fyad(:, ny)/rd_dy
    rda_fyad(:, ny  ) = 0.0_dp
    !
    rda_fad (:, 2:ny  ) = rda_fad(:, 2:ny  ) + rda_fyad(:, 1:ny-1)/rd_dy
    rda_fad (:, 1:ny-1) = rda_fad(:, 1:ny-1) - rda_fyad(:, 1:ny-1)/rd_dy
    rda_fyad(:, 1:ny-1) = 0.0_dp

    !x component
    !right boundary
    rda_fad(nx  , :) = rda_fad(nx  , :) + rda_fxad(nx, :)/rd_dx
    rda_fad(nx-1, :) = rda_fad(nx-1, :) - rda_fxad(nx, :)/rd_dx
    rda_fxad(nx , :) = 0.0_dp
    !
    rda_fad (2:nx  , :) = rda_fad(2:nx  , :) + rda_fxad(1:nx-1, :)/rd_dx
    rda_fad (1:nx-1, :) = rda_fad(1:nx-1, :) - rda_fxad(1:nx-1, :)/rd_dx
    rda_fxad(1:nx-1, :) = 0.0_dp
  END SUBROUTINE gradient_fcs_2dAdj

  SUBROUTINE gradient_ccs_1dAdj(rda_fad, rda_dfad, rd_dx)
    REAL(KIND=cp), DIMENSION(:), INTENT(INOUT) :: rda_fad !!scalar vector fieldwhich gradient is to be computed
    REAL(KIND=cp), DIMENSION(:), INTENT(INOUT) :: rda_dfad!!x (resp. y) component of the gradient
    REAL(KIND=cp),                  INTENT(IN)    :: rd_dx   !! x(resp. y) space step
    INTEGER :: n

    n = SIZE(rda_fad)

    !right boundary
    rda_fad (n  ) = rda_fad(n  ) + rda_dfad(n)/rd_dx
    rda_fad (n-1) = rda_fad(n-1) - rda_dfad(n)/rd_dx
    rda_dfad(n  ) = 0.0_dp
    !left boundary
    rda_fad (2) = rda_fad(2) + rda_dfad(1)/rd_dx
    rda_fad (1) = rda_fad(1) - rda_dfad(1)/rd_dx
    rda_dfad(1) = 0.0_dp
    !x : interior point
    rda_fad (3:n  ) = rda_fad(3:n  ) + rda_dfad(2:n-1)/(2*rd_dx)!centered diff
    rda_fad (1:n-2) = rda_fad(1:n-2) - rda_dfad(2:n-1)/(2*rd_dx)!centered diff
    rda_dfad(2:n-1) = 0.0_dp
  END SUBROUTINE gradient_ccs_1dAdj

  SUBROUTINE gradient_ccs_2dAdj(rda_fad, rda_fxad, rda_fyad, rd_dx, rd_dy)
    REAL(KIND=cp), DIMENSION(:, :), INTENT(INOUT) :: rda_fad!!scalar vector fieldwhich gradient is to be computed
    REAL(KIND=cp), DIMENSION(:, :), INTENT(INOUT) :: rda_fxad, rda_fyad!!x (resp. y) component of the gradient
    REAL(KIND=cp),                  INTENT(IN)    :: rd_dx, rd_dy!! x(resp. y) space step
    INTEGER :: nx, ny

    nx = SIZE(rda_fad, 1)
    ny = SIZE(rda_fad, 2)

    !y component
    !upper boundary
    rda_fad (:, ny  ) = rda_fad(:, ny  ) + rda_fyad(:, ny)/rd_dy
    rda_fad (:, ny-1) = rda_fad(:, ny-1) - rda_fyad(:, ny)/rd_dy
    rda_fyad(:, ny  ) = 0.0_dp
    !bottom boundary
    rda_fad (:, 2) = rda_fad(:, 2) + rda_fyad(:, 1)/rd_dy
    rda_fad (:, 1) = rda_fad(:, 1) - rda_fyad(:, 1)/rd_dy
    rda_fyad(:, 1) = 0.0_dp
    !y : interior point
    rda_fad (:, 3:ny  ) = rda_fad(:, 3:ny  ) + rda_fyad(:, 2:ny-1)/(2*rd_dy)!centered diff
    rda_fad (:, 1:ny-2) = rda_fad(:, 1:ny-2) - rda_fyad(:, 2:ny-1)/(2*rd_dy)!centered diff
    rda_fyad(:, 2:ny-1) = 0.0_dp

    !x component
    !right boundary
    rda_fad(nx  , :) = rda_fad(nx  , :) + rda_fxad(nx, :)/rd_dx
    rda_fad(nx-1, :) = rda_fad(nx-1, :) - rda_fxad(nx, :)/rd_dx
    rda_fxad(nx , :) = 0.0_dp
    !left boundary
    rda_fad(2, :) = rda_fad(2, :) + rda_fxad(1, :)/rd_dx
    rda_fad(1, :) = rda_fad(1, :) - rda_fxad(1, :)/rd_dx
    rda_fxad(1, :)= 0.0_dp
    !x : interior point
    rda_fad (3:nx  , :) = rda_fad(3:nx  , :) + rda_fxad(2:nx-1, :)/(2*rd_dx)!centered diff
    rda_fad (1:nx-2, :) = rda_fad(1:nx-2, :) - rda_fxad(2:nx-1, :)/(2*rd_dx)!centered diff
    rda_fxad(2:nx-1, :) = 0.0_dp
  END SUBROUTINE gradient_ccs_2dAdj

  SUBROUTINE gradient_bcs_1dAdj(rda_fad, rda_dfad, rd_dx)
    REAL(KIND=cp), DIMENSION(:), INTENT(INOUT) :: rda_fad !!scalar vector fieldwhich gradient is to be computed
    REAL(KIND=cp), DIMENSION(:), INTENT(INOUT) :: rda_dfad!!x (resp. y) component of the gradient
    REAL(KIND=cp),                  INTENT(IN) :: rd_dx   !! x(resp. y) space step
    INTEGER :: n

    n = SIZE(rda_fad)
    !
    rda_fad (2:n  ) = rda_fad(2:n  ) + rda_dfad(2:n)/rd_dx
    rda_fad (1:n-1) = rda_fad(1:n-1) - rda_dfad(2:n)/rd_dx
    rda_dfad(2:n  ) = 0.0_dp
    !left boundary
    rda_fad (2) = rda_fad(2) + rda_dfad(1)/rd_dx
    rda_fad (1) = rda_fad(1) - rda_dfad(1)/rd_dx
    rda_dfad(1) = 0.0_dp
  END SUBROUTINE gradient_bcs_1dAdj

  SUBROUTINE gradient_bvs_1dAdj(rda_fad, rda_dfad, rda_x)
    REAL(KIND=cp), DIMENSION(:), INTENT(INOUT) :: rda_fad !!scalar vector fieldwhich gradient is to be computed
    REAL(KIND=cp), DIMENSION(:), INTENT(INOUT) :: rda_dfad!!x (resp. y) component of the gradient
    REAL(KIND=cp), DIMENSION(:), INTENT(IN)    :: rda_x   !! x(resp. y) space step
    INTEGER :: n

    n = SIZE(rda_fad)
    !
    rda_fad (2:n  ) = rda_fad(2:n  ) + rda_dfad(2:n)/( rda_x(2:n)-rda_x(1:n-1) )
    rda_fad (1:n-1) = rda_fad(1:n-1) - rda_dfad(2:n)/( rda_x(2:n)-rda_x(1:n-1) )
    rda_dfad(2:n  ) = 0.0_dp
    !left boundary
    rda_fad (2) = rda_fad(2) + rda_dfad(1)/( rda_x(2  )-rda_x(1    ) )
    rda_fad (1) = rda_fad(1) - rda_dfad(1)/( rda_x(2  )-rda_x(1    ) )
    rda_dfad(1) = 0.0_dp
  END SUBROUTINE gradient_bvs_1dAdj

  SUBROUTINE gradient_bcs_2dAdj(rda_fad, rda_fxad, rda_fyad, rd_dx, rd_dy)
    REAL(KIND=cp), DIMENSION(:, :), INTENT(INOUT) :: rda_fad!!scalar vector fieldwhich gradient is to be computed
    REAL(KIND=cp), DIMENSION(:, :), INTENT(INOUT) :: rda_fxad, rda_fyad!!x (resp. y) component of the gradient
    REAL(KIND=cp),                  INTENT(IN)    :: rd_dx, rd_dy!! x(resp. y) space step
    INTEGER :: nx, ny

    nx = SIZE(rda_fad, 1)
    ny = SIZE(rda_fad, 2)

    !y component
    !
    rda_fad (:, 2:ny  ) = rda_fad(:, 2:ny  ) + rda_fyad(:, 2:ny)/rd_dy
    rda_fad (:, 1:ny-1) = rda_fad(:, 1:ny-1) - rda_fyad(:, 2:ny)/rd_dy
    rda_fyad(:, 2:ny  ) = 0.0_dp
    !bottom boundary
    rda_fad (:, 2) = rda_fad(:, 2) + rda_fyad(:, 1)/rd_dy
    rda_fad (:, 1) = rda_fad(:, 1) - rda_fyad(:, 1)/rd_dy
    rda_fyad(:, 1) = 0.0_dp

    !x component
    !
    rda_fad (2:nx  , :) = rda_fad(2:nx  , :) + rda_fxad(2:nx, :)/rd_dx
    rda_fad (1:nx-1, :) = rda_fad(1:nx-1, :) - rda_fxad(2:nx, :)/rd_dx
    rda_fxad(2:nx  , :) = 0.0_dp
    !left boundary
    rda_fad (2, :) = rda_fad(2, :) + rda_fxad(1, :)/rd_dx
    rda_fad (1, :) = rda_fad(1, :) - rda_fxad(1, :)/rd_dx
    rda_fxad(1 , :) = 0.0_dp
  END SUBROUTINE gradient_bcs_2dAdj

  !> \brief adjoint subroutine
  !!
  !<
  SUBROUTINE geostrophic_wind_cgridAdj(rda_hb, rda_ub, rda_vb, rd_dx, rd_dy, rd_g, rda_fu, rda_fv)
    REAL(KIND=cp),DIMENSION(:,:), INTENT(IN OUT) :: rda_hb
    REAL(KIND=cp),DIMENSION(:,:), INTENT(IN OUT) :: rda_ub
    REAL(KIND=cp),DIMENSION(:,:), INTENT(IN OUT) :: rda_vb
    REAL(KIND=cp), DIMENSION(:)  , INTENT(IN)  :: rda_fu, rda_fv
    REAL(KIND=cp), INTENT(IN) :: rd_dx, rd_dy, rd_g
    !Local variables
    INTEGER :: i0, im, j0, jm, ibi, ibj

    i0 = 1
    im = SIZE(rda_hb, 1)
    j0 = 1
    jm = SIZE(rda_hb, 2)

    !left differences for the to top row
    ibi = im!recomputation of index
    rda_hb(ibi  ,j0:jm-1) = rda_hb(ibi  ,j0:jm-1) + (rd_g/rda_fv)*rda_vb(ibi,:)/(2.0_cp*rd_dx)
    rda_hb(ibi  ,j0+1:jm) = rda_hb(ibi  ,j0+1:jm) + (rd_g/rda_fv)*rda_vb(ibi,:)/(2.0_cp*rd_dx)
    rda_hb(ibi-1,j0:jm-1) = rda_hb(ibi-1,j0:jm-1) - (rd_g/rda_fv)*rda_vb(ibi,:)/(2.0_cp*rd_dx)
    rda_hb(ibi-1,j0+1:jm) = rda_hb(ibi-1,j0+1:jm) - (rd_g/rda_fv)*rda_vb(ibi,:)/(2.0_cp*rd_dx)
    rda_vb(ibi  ,:      ) = 0.0_cp

    !right differences
    DO ibi = im-1,1,-1
      rda_hb(ibi+1,j0:jm-1) = rda_hb(ibi+1,j0:jm-1) + (rd_g/rda_fv)*rda_vb(ibi,:)/(2.0_cp*rd_dx)
      rda_hb(ibi+1,j0+1:jm) = rda_hb(ibi+1,j0+1:jm) + (rd_g/rda_fv)*rda_vb(ibi,:)/(2.0_cp*rd_dx)
      rda_hb(ibi  ,j0:jm-1) = rda_hb(ibi  ,j0:jm-1) - (rd_g/rda_fv)*rda_vb(ibi,:)/(2.0_cp*rd_dx)
      rda_hb(ibi  ,j0+1:jm) = rda_hb(ibi  ,j0+1:jm) - (rd_g/rda_fv)*rda_vb(ibi,:)/(2.0_cp*rd_dx)
      rda_vb(ibi  ,:      ) = 0.0_cp
    END DO

    !left differences for the to top row
    ibj = jm
    rda_hb(i0:im-1,ibj  ) = rda_hb(i0:im-1,ibj  ) + ( rd_g/rda_fu(ibj) )*rda_ub(:, ibj)/(2.0_cp*rd_dy)
    rda_hb(i0+1:im,ibj  ) = rda_hb(i0+1:im,ibj  ) + ( rd_g/rda_fu(ibj) )*rda_ub(:, ibj)/(2.0_cp*rd_dy)
    rda_hb(i0:im-1,ibj-1) = rda_hb(i0:im-1,ibj-1) - ( rd_g/rda_fu(ibj) )*rda_ub(:, ibj)/(2.0_cp*rd_dy)
    rda_hb(i0+1:im,ibj-1) = rda_hb(i0+1:im,ibj-1) - ( rd_g/rda_fu(ibj) )*rda_ub(:, ibj)/(2.0_cp*rd_dy)
    rda_ub(:      ,ibj  ) = 0.0_cp

    !right differences
    DO ibj = jm-1,1,-1
      rda_hb(i0:im-1,ibj+1) = rda_hb(i0:im-1,ibj+1) + ( rd_g/rda_fu(ibj) )*rda_ub(:, ibj)/(2.0_cp*rd_dy)
      rda_hb(i0+1:im,ibj+1) = rda_hb(i0+1:im,ibj+1) + ( rd_g/rda_fu(ibj) )*rda_ub(:, ibj)/(2.0_cp*rd_dy)
      rda_hb(i0:im-1,ibj  ) = rda_hb(i0:im-1,ibj  ) - ( rd_g/rda_fu(ibj) )*rda_ub(:, ibj)/(2.0_cp*rd_dy)
      rda_hb(i0+1:im,ibj  ) = rda_hb(i0+1:im,ibj  ) - ( rd_g/rda_fu(ibj) )*rda_ub(:, ibj)/(2.0_cp*rd_dy)
      rda_ub(:      , ibj ) = 0.0_cp
    END DO
  END SUBROUTINE geostrophic_wind_cgridAdj

  !> \brief Computes the gradient regularization term associated with a scalar function of one variable
  !<
  SUBROUTINE grad_regul_cs_1dAdj(rda_f, rda_fad, method, rd_dx, rl_regad)
    REAL(KIND=cp), DIMENSION(:), INTENT(IN)    :: rda_f
    REAL(KIND=cp), DIMENSION(:), INTENT(INOUT) :: rda_fad
    INTEGER,                     INTENT(IN)    :: method
    REAL(KIND=cp),               INTENT(IN)    :: rd_dx
    REAL(KIND=cp),               INTENT(INOUT) :: rl_regad
    !local variables
    REAL(KIND=cp), DIMENSION( SIZE(rda_f) )    :: rla_fx, rla_fxad!!gradient
    !REAL(KIND=cp)                              :: rl_reg !! Regularization term

    !zeroing local adjoint variables
    rla_fxad = 0.0_cp
    !end of zeroing
    !recomputing
    CALL gradient_cs_1d(rda_f, rla_fx, method, rd_dx)
    !end of recomputing
    CALL square_L2_normAdj(rla_fx, rla_fxad, rl_regad)
    CALL gradientAdj(rda_fad, rla_fxad, method, rd_dx)
  END SUBROUTINE grad_regul_cs_1dAdj

  !> \brief Computes the gradient regularization term associated with a scalar function of one variable
  !<
  SUBROUTINE grad_regul_cs_1d_defaultAdj(rda_f, rda_fad, method, rl_regad)
    REAL(KIND=cp), DIMENSION(:), INTENT(IN)    :: rda_f
    REAL(KIND=cp), DIMENSION(:), INTENT(INOUT) :: rda_fad
    INTEGER,                     INTENT(IN)    :: method
    REAL(KIND=cp),               INTENT(INOUT) :: rl_regad
    !local variables
    REAL(KIND=cp)                              :: rl_dx !! Regularization term

    !recomputing
    rl_dx = disc_step()
    !end of recomputing
    CALL grad_regul_cs_1dAdj(rda_f, rda_fad, method, rl_dx, rl_regad)
  END SUBROUTINE grad_regul_cs_1d_defaultAdj

  !> \brief Computes the gradient regularization term associated with a scalar function of one variable
  !<
  SUBROUTINE grad_regul_vs_1dAdj(rda_f, rda_fad, method, rda_x, rl_regad)
    REAL(KIND=cp), DIMENSION(:), INTENT(IN)    :: rda_f, rda_x
    REAL(KIND=cp), DIMENSION(:), INTENT(INOUT) :: rda_fad
    INTEGER,                     INTENT(IN)    :: method
    REAL(KIND=cp),               INTENT(INOUT) :: rl_regad
    !local variables
    REAL(KIND=cp), DIMENSION( SIZE(rda_f) ) :: rla_fx!!gradient
    REAL(KIND=cp), DIMENSION( SIZE(rda_f) ) :: rla_fxad!!gradient
    !REAL(KIND=cp)                           :: rl_reg !! Regularization term
    !zeroing local adjoint variables
    rla_fxad = 0.0_cp
    !end of zeroing
    !recomputing
    CALL gradient(rda_f, rla_fx, method, rda_x)
    !end of recomputing
    CALL square_L2_normAdj(rla_fx, rla_fxad, rl_regad)
    CALL gradientAdj(rda_fad, rla_fxad, method, rda_x)
  END SUBROUTINE grad_regul_vs_1dAdj

  !> \brief Computes the gradient regularization term associated with a scalar function of two variables
  !<
  SUBROUTINE grad_regul_cs_2dAdj(rda_f, rda_fad, method, rd_dx, rd_dy, rl_regad)
    REAL(KIND=cp), DIMENSION(:,:), INTENT(IN)    :: rda_f
    REAL(KIND=cp), DIMENSION(:,:), INTENT(INOUT) :: rda_fad
    INTEGER,                       INTENT(IN)    :: method
    REAL(KIND=cp),                 INTENT(IN)    :: rd_dx, rd_dy
    REAL(KIND=cp),                 INTENT(INOUT) :: rl_regad
    !local variables
    REAL(KIND=cp), DIMENSION( SIZE(rda_f,1),SIZE(rda_f,2) ) :: rla_fx, rla_fy, rla_fxad, rla_fyad!!gradient
    REAL(KIND=cp) :: rl_regxad, rl_regyad!! Regularization term
    !zeroing local adjoint variables
    rla_fxad  = 0.0_cp
    rla_fyad  = 0.0_cp
    rl_regxad = 0.0_cp
    rl_regyad = 0.0_cp
    !end of zeroing
    !recomputing
    CALL gradient(rda_f, rla_fx, rla_fy, method, rd_dx, rd_dy)
    !end of recomputing
    rl_regyad = rl_regyad + rl_regad
    rl_regxad = rl_regxad + rl_regad
    rl_regad  = 0.0_cp
    CALL square_L2_normAdj(rla_fy, rla_fyad, rl_regyad)
    CALL square_L2_normAdj(rla_fx, rla_fxad, rl_regxad)
    CALL gradientAdj(rda_fad, rla_fxad, rla_fyad, method, rd_dx, rd_dy)
  END SUBROUTINE grad_regul_cs_2dAdj

  !> \brief Computes the gradient regularization term associated with a scalar function of two variables
  !<
  SUBROUTINE grad_regul_cs_v2dAdj(rda_f, rda_fad, id_nx, id_ny, method, rd_dx, rd_dy, rl_regad)
    REAL(KIND=cp), DIMENSION(:), INTENT(IN)      :: rda_f
    REAL(KIND=cp), DIMENSION(:), INTENT(INOUT)   :: rda_fad
    INTEGER,                       INTENT(IN)    :: method, id_nx, id_ny
    REAL(KIND=cp),                 INTENT(IN)    :: rd_dx, rd_dy
    REAL(KIND=cp),                 INTENT(INOUT) :: rl_regad
    !local variables
    REAL(KIND=cp), DIMENSION(id_nx, id_ny)       :: rla_f, rla_fad
    !zeroing local adjoint variables
    rla_fad = 0.0_cp
    !end of zeroing
    !recomputing
    rla_f = RESHAPE(rda_f, (/id_nx, id_ny/) )
    !end of recomputing
    CALL grad_regul_cs_2dAdj(rla_f, rla_fad, method, rd_dx, rd_dy, rl_regad)
    rda_fad = rda_fad + RESHAPE(rla_fad, (/id_nx*id_ny/) )
    rla_fad = 0.0_cp
  END SUBROUTINE grad_regul_cs_v2dAdj

  !> \brief Computes the gradient regularization term associated with a scalar function of two variables
  !<
  SUBROUTINE grad_regul_cs_2d_defaultAdj(rda_f, rda_fad, method, rl_regad)
    REAL(KIND=cp), DIMENSION(:,:), INTENT(IN)    :: rda_f
    REAL(KIND=cp), DIMENSION(:,:), INTENT(INOUT) :: rda_fad
    INTEGER,                       INTENT(IN)    :: method
    REAL(KIND=cp),                 INTENT(INOUT) :: rl_regad
    !local variables
    REAL(KIND=cp)                                :: rl_dx, rl_dy
    !recomputing
    rl_dx = disc_step()
    rl_dy = disc_step()
    !end of recomputing
    CALL grad_regul_cs_2dAdj(rda_f, rda_fad, method, rl_dx, rl_dy, rl_regad)
  END SUBROUTINE grad_regul_cs_2d_defaultAdj

  !> \brief Computes the gradient regularization term associated with a scalar function of two variables
  !<
  SUBROUTINE grad_regul_cs_v2d_defaultAdj(rda_f, rda_fad, id_nx, id_ny, method, rl_regad)
    REAL(KIND=cp), DIMENSION(:), INTENT(IN)      :: rda_f
    REAL(KIND=cp), DIMENSION(:), INTENT(INOUT)   :: rda_fad
    INTEGER,                       INTENT(IN)    :: method, id_nx, id_ny
    REAL(KIND=cp),                 INTENT(INOUT) :: rl_regad
    !local variables
    REAL(KIND=cp), DIMENSION(id_nx, id_ny)       :: rla_f, rla_fad
    REAL(KIND=cp)                                :: rl_dx, rl_dy
    !zeroing local adjoint variables
    rla_fad = 0.0_cp
    !end of zeroing
    !recomputing
    rl_dx = disc_step()
    rl_dy = disc_step()
    rla_f = RESHAPE(rda_f, (/id_nx, id_ny/) )
    !end of recomputing
    CALL grad_regul_cs_2dAdj(rla_f, rla_fad, method, rl_dx, rl_dy, rl_regad)
    rda_fad = rda_fad + RESHAPE(rla_fad, (/id_nx*id_ny/) )
    rla_fad = 0.0_cp
  END SUBROUTINE grad_regul_cs_v2d_defaultAdj

  !<
  SUBROUTINE tikhonov_regul_1dAdj(rda_f, rda_fad, rl_regad, rda_bf)
    REAL(KIND=cp), DIMENSION(:), INTENT(IN) :: rda_f
    REAL(KIND=cp), DIMENSION(:), INTENT(IN OUT) :: rda_fad
    REAL(KIND=cp), DIMENSION(:), OPTIONAL, INTENT(IN) :: rda_bf
    !local variables
    REAL(KIND=cp)                  :: rl_regad !! Regularization term
    REAL(KIND=cp), DIMENSION(SIZE(rda_f,1)) :: rla_f, rla_fad

    !recomputation
    IF( PRESENT(rda_bf) )THEN
      rla_f = rda_f - rda_bf
    ELSE
      rla_f = rda_f
    END IF
    rla_fad = 0.0_dp

    CALL square_L2_normAdj(rla_f, rla_fad, rl_regad)

    !this part is independent of the presence or not of the background term
    rda_fad = rda_fad + rla_fad
    rla_fad = 0.0_cp
  END SUBROUTINE tikhonov_regul_1dAdj

  !<
  SUBROUTINE tikhonov_regul_2dAdj(rda_f, rda_fad, rl_regad, rda_bf)
    REAL(KIND=cp), DIMENSION(:,:), INTENT(IN) :: rda_f
    REAL(KIND=cp), DIMENSION(:,:), OPTIONAL, INTENT(IN) :: rda_bf
    REAL(KIND=cp), DIMENSION(:,:), INTENT(IN OUT) :: rda_fad
    !local variables
    REAL(KIND=cp)                  :: rl_regad !! Regularization term
    REAL(KIND=cp), DIMENSION(SIZE(rda_f,1),SIZE(rda_f,2)) :: rla_f, rla_fad

    IF( PRESENT(rda_bf) )THEN
      rla_f = rda_f - rda_bf
    ELSE
      rla_f = rda_f
    END IF
    rla_fad = 0.0_dp
    CALL square_L2_normAdj(rla_f, rla_fad, rl_regad)
    !this part is independent of the presence or not of the background term
    rda_fad = rda_fad + rla_fad
    rla_fad = 0.0_cp
  END SUBROUTINE tikhonov_regul_2dAdj

  !> \brief adjoint subroutine
  SUBROUTINE geostrophic_regul_cgridAdj(&
                rda_h, rda_had, rda_u, rda_uad, rda_v, rda_vad, rd_dx, rd_dy, rd_g, rda_fu, rda_fv, rl_regad&
             )
    REAL(KIND=cp), DIMENSION(:,:), INTENT(IN)     :: rda_h, rda_u, rda_v
    REAL(KIND=cp), DIMENSION(:,:), INTENT(IN OUT) :: rda_had, rda_uad, rda_vad
    REAL(KIND=cp), DIMENSION(:)  , INTENT(IN)     :: rda_fu, rda_fv
    REAL(KIND=cp), INTENT(IN) :: rd_dx, rd_dy, rd_g
    REAL(KIND=cp), INTENT(IN OUT) :: rl_regad
    !local variables
    REAL(KIND=cp) :: rl_reguad, rl_regvad !! Regularization term
    REAL(KIND=cp), DIMENSION(SIZE(rda_u,1),SIZE(rda_u,2)) :: rla_gu, rla_du
    REAL(KIND=cp), DIMENSION(SIZE(rda_u,1),SIZE(rda_u,2)) :: rla_guad, rla_duad
    REAL(KIND=cp), DIMENSION(SIZE(rda_v,1),SIZE(rda_v,2)) :: rla_gv, rla_dv
    REAL(KIND=cp), DIMENSION(SIZE(rda_v,1),SIZE(rda_v,2)) :: rla_gvad, rla_dvad

    !zeroing local adjoint variables
    rl_reguad = 0.0_cp
    rl_regvad = 0.0_cp
    rla_guad  = 0.0_cp
    rla_duad  = 0.0_cp
    rla_gvad  = 0.0_cp
    rla_dvad  = 0.0_cp
    !recomputation
    CALL geostrophic_wind_cgrid(rda_h, rla_gu, rla_gv, rd_dx, rd_dy, rd_g, rda_fu, rda_fv)
    rla_du = rda_u - rla_gu
    rla_dv = rda_v - rla_gv
    !end of recomputation
    rl_reguad = rl_reguad + rl_regad
    rl_regvad = rl_regvad + rl_regad
    rl_regad = 0.0_cp
    CALL square_L2_normAdj(rla_dv, rla_dvad, rl_regvad)
    rda_vad = rda_vad + rla_dvad
    rla_gvad = rla_gvad - rla_dvad
    rla_dvad = 0.0_cp
    CALL square_L2_normAdj(rla_du, rla_duad, rl_reguad)
    rda_uad = rda_uad + rla_duad
    rla_guad = rla_guad - rla_duad
    rla_duad = 0.0_cp
    CALL geostrophic_wind_cgridAdj(rda_had, rla_guad, rla_gvad, rd_dx, rd_dy, rd_g, rda_fu, rda_fv)
  END SUBROUTINE geostrophic_regul_cgridAdj

END MODULE regul_toolsadj


! Copyright (c) 2016 Alex Kramer <kramer.alex.kramer@gmail.com>
! See the LICENSE.txt file in the top-level directory of this distribution

! Methods for multiplying tridiagonal matrices by a vector; these are in
! general much more efficient than standard matrix multiplication.
!
! This module provides the following subroutines:
!
! tridiag_matmul_gen(...) -> general tridiagonal matrix
! tridiag_matmul_cnst(...) -> all elements cosntant, band-wise
! tridiag_matmul_cnst_diag(...) -> diagonal elements constant
! tridiag_matmul_cnst_odiag(...) -> off-diagonal elements constant, band-wise
!
! tridiag_sym(...) -> symmetric tridiagonal matrix
! tridiag_sym_cnst(...) -> symmetric, all elements constant, band-wise
! tridiag_sym_cnst_diag(...) -> symmetric, diagonal elements constant
! tridiag_sym_cnst_odiag(...) -> symmetric, off-diagonal elements constant
!   band-wise
!
! Note that the methods for symmetric tridiagonal matrices are simply wrappers
! around the methods for the more general asymmetric case. There are currently
! no symmetry-specific numerical optimizations.
module tridiag_matmul

  ! Numeric precision parameters
  use iso_fortran_env, only: sp=>real32, dp=>real64, ip=>int32

  implicit none
  private

  public :: tridiag_matmul_gen
  interface tridiag_matmul_gen
     ! Multiply general tridiagonal matrix by vector
     module procedure tridiag_matmul_gen_real_dp
     module procedure tridiag_matmul_gen_cmplx_dp
     module procedure tridiag_matmul_gen_real_sp
     module procedure tridiag_matmul_gen_cmplx_sp
  end interface tridiag_matmul_gen

  public :: tridiag_matmul_cnst
  interface tridiag_matmul_cnst
     ! Multiply tridiagonal matrix by vector where all elements are equal,
     ! band-wise
     module procedure tridiag_matmul_cnst_real_dp
     module procedure tridiag_matmul_cnst_cmplx_dp
     module procedure tridiag_matmul_cnst_real_sp
     module procedure tridiag_matmul_cnst_cmplx_sp
  end interface tridiag_matmul_cnst

  public :: tridiag_matmul_cnst_diag
  interface tridiag_matmul_cnst_diag
     ! Multiply tridiagonal matrix by vector where diagonal elements are equal
     module procedure tridiag_matmul_cnst_diag_real_dp
     module procedure tridiag_matmul_cnst_diag_cmplx_dp
     module procedure tridiag_matmul_cnst_diag_real_sp
     module procedure tridiag_matmul_cnst_diag_cmplx_sp
  end interface tridiag_matmul_cnst_diag

  public :: tridiag_matmul_cnst_odiag
  interface tridiag_matmul_cnst_odiag
     ! Multiply tridiagonal matrix by vector where off-diagonal elements are
     ! equal, band-wise
     module procedure tridiag_matmul_cnst_odiag_real_dp
     module procedure tridiag_matmul_cnst_odiag_cmplx_dp
     module procedure tridiag_matmul_cnst_odiag_real_sp
     module procedure tridiag_matmul_cnst_odiag_cmplx_sp
  end interface tridiag_matmul_cnst_odiag

  public :: tridiag_matmul_sym
  interface tridiag_matmul_sym
     ! Multiply symmetric tridiagonal matrix by vector
     module procedure tridiag_matmul_sym_real_dp
     module procedure tridiag_matmul_sym_cmplx_dp
     module procedure tridiag_matmul_sym_real_sp
     module procedure tridiag_matmul_sym_cmplx_sp
  end interface tridiag_matmul_sym

  public :: tridiag_matmul_sym_cnst
  interface tridiag_matmul_sym_cnst
     ! Multiply symmetric tridiagonal matrix by vector, where all elements are
     ! equal, band-wise
     module procedure tridiag_matmul_sym_cnst_real_dp
     module procedure tridiag_matmul_sym_cnst_cmplx_dp
     module procedure tridiag_matmul_sym_cnst_real_sp
     module procedure tridiag_matmul_sym_cnst_cmplx_sp
  end interface tridiag_matmul_sym_cnst

  public :: tridiag_matmul_sym_cnst_diag
  interface tridiag_matmul_sym_cnst_diag
     ! Multiply symmetric tridiagonal matrix by vector, where diagonal elements
     ! are constant
     module procedure tridiag_matmul_sym_cnst_diag_real_dp
     module procedure tridiag_matmul_sym_cnst_diag_cmplx_dp
     module procedure tridiag_matmul_sym_cnst_diag_real_sp
     module procedure tridiag_matmul_sym_cnst_diag_cmplx_sp
  end interface tridiag_matmul_sym_cnst_diag

  public :: tridiag_matmul_sym_cnst_odiag
  interface tridiag_matmul_sym_cnst_odiag
     ! Multiply symmetric tridiagonal matrix by vector, where off-diagonal
     ! elements are constant, band-wise
     module procedure tridiag_matmul_sym_cnst_odiag_real_dp
     module procedure tridiag_matmul_sym_cnst_odiag_cmplx_dp
     module procedure tridiag_matmul_sym_cnst_odiag_real_sp
     module procedure tridiag_matmul_sym_cnst_odiag_cmplx_sp
  end interface tridiag_matmul_sym_cnst_odiag

contains

  ! subroutine tridiag_matmul_gen
  !
  ! Multiply general tridiagonal matrix by vector
  !
  ! diag(n) :: diagonal entries
  ! u_diag(n - 1) :: upper diagonal entries
  ! l_diag(n - 1) :: upper diagonal entries
  ! vec(n) :: vector to multiply
  ! res(n) :: result of multiplication

  ! tridiag_matmul_gen definition for double-precision real values
  subroutine tridiag_matmul_gen_real_dp(diag, u_diag, l_diag, vec, res)
    real(dp), intent(in) :: vec(:)
    real(dp), intent(in) :: diag(size(vec))
    real(dp), intent(in) :: u_diag(size(diag) - 1)
    real(dp), intent(in) :: l_diag(size(diag) - 1)
    real(dp), intent(inout) :: res(size(diag))

    include "./tridiag_matmul_src/gen.src"
  end subroutine tridiag_matmul_gen_real_dp

  ! tridiag_matmul_gen definition for double-precision complex values
  subroutine tridiag_matmul_gen_cmplx_dp(diag, u_diag, l_diag, vec, res)
    complex(dp), intent(in) :: vec(:)
    complex(dp), intent(in) :: diag(size(vec))
    complex(dp), intent(in) :: u_diag(size(diag) - 1)
    complex(dp), intent(in) :: l_diag(size(diag) - 1)
    complex(dp), intent(inout) :: res(size(diag))

    include "./tridiag_matmul_src/gen.src"
  end subroutine tridiag_matmul_gen_cmplx_dp

  ! tridiag_matmul_gen definition for single-precision real values
  subroutine tridiag_matmul_gen_real_sp(diag, u_diag, l_diag, vec, res)
    real(sp), intent(in) :: vec(:)
    real(sp), intent(in) :: diag(size(vec))
    real(sp), intent(in) :: u_diag(size(diag) - 1)
    real(sp), intent(in) :: l_diag(size(diag) - 1)
    real(sp), intent(inout) :: res(size(diag))

    include "./tridiag_matmul_src/gen.src"
  end subroutine tridiag_matmul_gen_real_sp

  ! tridiag_matmul_gen definition for single-precision complex values
  subroutine tridiag_matmul_gen_cmplx_sp(diag, u_diag, l_diag, vec, res)
    complex(sp), intent(in) :: vec(:)
    complex(sp), intent(in) :: diag(size(vec))
    complex(sp), intent(in) :: u_diag(size(diag) - 1)
    complex(sp), intent(in) :: l_diag(size(diag) - 1)
    complex(sp), intent(inout) :: res(size(diag))

    include "./tridiag_matmul_src/gen.src"
  end subroutine tridiag_matmul_gen_cmplx_sp

  ! subroutine tridiag_matmul_cnst
  !
  ! Multiply tridiagonal matrix by a vector, where the band elements are
  ! equal (band-wise)
  !
  ! diag_cnst :: diagonal entry
  ! u_diag_cnst :: upper diagonal entry
  ! l_diag_cnnst :: lower diagonal entry
  ! vec(n) :: vector to multiply
  ! res(n) :: result of multiplication

  ! tridiag_matmul_cnst definition for double-precision real values
  subroutine tridiag_matmul_cnst_real_dp(diag_cnst, u_diag_cnst, &
       l_diag_cnst, vec, res)
    real(dp), intent(in) :: diag_cnst, u_diag_cnst, l_diag_cnst
    real(dp), intent(in) :: vec(:)
    real(dp), intent(inout) :: res(size(vec))

    include "./tridiag_matmul_src/cnst.src"
  end subroutine tridiag_matmul_cnst_real_dp

  ! tridiag_matmul_cnst definition for double-precision complex values
  subroutine tridiag_matmul_cnst_cmplx_dp(diag_cnst, u_diag_cnst, &
       l_diag_cnst, vec, res)
    complex(dp), intent(in) :: diag_cnst, u_diag_cnst, l_diag_cnst
    complex(dp), intent(in) :: vec(:)
    complex(dp), intent(inout) :: res(size(vec))

    include "./tridiag_matmul_src/cnst.src"
  end subroutine tridiag_matmul_cnst_cmplx_dp

  ! tridiag_mmatmul_cnst definition for single-precision real values
  subroutine tridiag_matmul_cnst_real_sp(diag_cnst, u_diag_cnst, &
       l_diag_cnst, vec, res)
    real(sp), intent(in) :: diag_cnst, u_diag_cnst, l_diag_cnst
    real(sp), intent(in) :: vec(:)
    real(sp), intent(inout) :: res(size(vec))

    include "./tridiag_matmul_src/cnst.src"
  end subroutine tridiag_matmul_cnst_real_sp

  ! tridiag_matmul_cnst defintion for single-precision complex values
  subroutine tridiag_matmul_cnst_cmplx_sp(diag_cnst, u_diag_cnst, &
       l_diag_cnst, vec, res)
    complex(sp), intent(in) :: diag_cnst, u_diag_cnst, l_diag_cnst
    complex(sp), intent(in) :: vec(:)
    complex(sp), intent(inout) :: res(size(vec))

    include "./tridiag_matmul_src/cnst.src"
  end subroutine tridiag_matmul_cnst_cmplx_sp

  ! subroutine tridiag_matmul_cnst_diag
  !
  ! Multiply tridiagonal matrix by a vector, where the diagonal elements are
  ! equal
  !
  ! diag_cnst :: diagonal element
  ! u_diag(n - 1) :: upper diagonal elements
  ! l_diag(n - 1) :: lower diagonal elements
  ! vec(n) :: vector to multiply
  ! res(n) :: result of multiplication

  ! tridiag_matmul_cnst_diag definition for double-precision real values
  subroutine tridiag_matmul_cnst_diag_real_dp(diag_cnst, u_diag, l_diag, &
       vec, res)
    real(dp), intent(in) :: vec(:)
    real(dp), intent(in) :: diag_cnst
    real(dp), intent(in) :: u_diag(size(vec) - 1), l_diag(size(vec) - 1)
    real(dp), intent(inout) :: res(size(vec))

    include "./tridiag_matmul_src/cnst_diag.src"
  end subroutine tridiag_matmul_cnst_diag_real_dp

  ! tridiag_matmul_cnst_diag definition for double-precision complex values
  subroutine tridiag_matmul_cnst_diag_cmplx_dp(diag_cnst, u_diag, l_diag, &
       vec, res)
    complex(dp), intent(in) :: vec(:)
    complex(dp), intent(in) :: diag_cnst
    complex(dp), intent(in) :: u_diag(size(vec) - 1), l_diag(size(vec) - 1)
    complex(dp), intent(inout) :: res(size(vec))

    include "./tridiag_matmul_src/cnst_diag.src"
  end subroutine tridiag_matmul_cnst_diag_cmplx_dp

  ! tridiag_matmul_cnst_diag definition for single-precision real values
  subroutine tridiag_matmul_cnst_diag_real_sp(diag_cnst, u_diag, l_diag, &
       vec, res)
    real(sp), intent(in) :: vec(:)
    real(sp), intent(in) :: diag_cnst
    real(sp), intent(in) :: u_diag(size(vec) - 1), l_diag(size(vec) - 1)
    real(sp), intent(inout) :: res(size(vec))

    include "./tridiag_matmul_src/cnst_diag.src"
  end subroutine tridiag_matmul_cnst_diag_real_sp

  ! tridiag_matmul_cnst_diag definition for double-precision complex values
  subroutine tridiag_matmul_cnst_diag_cmplx_sp(diag_cnst, u_diag, l_diag, &
       vec, res)
    complex(sp), intent(in) :: vec(:)
    complex(sp), intent(in) :: diag_cnst
    complex(sp), intent(in) :: u_diag(size(vec) - 1), l_diag(size(vec) - 1)
    complex(sp), intent(inout) :: res(size(vec))

    include "./tridiag_matmul_src/cnst_diag.src"
  end subroutine tridiag_matmul_cnst_diag_cmplx_sp

  ! subroutine tridiag_matmul_cnst_offdiag
  !
  ! Multiply tridiagonal matrix by a vector, where the off-diagonal band
  ! elements are equal (band-wise)
  !
  ! diag(n) :: diagonal elements
  ! u_diag_cnst :: upper diagonal entry
  ! l_diag_cnst :: lower diagonal entry
  ! vec(n) :: vector to multiply
  ! res(n) :: result of multiplication

  ! tridiag_matmul_cnst_offdiag definition for double-precision real values
  subroutine tridiag_matmul_cnst_odiag_real_dp(diag, u_diag_cnst, &
       l_diag_cnst, vec, res)
    real(dp), intent(in) :: vec(:)
    real(dp), intent(in) :: diag(size(vec))
    real(dp), intent(in) :: u_diag_cnst, l_diag_cnst
    real(dp), intent(inout) :: res(size(vec))

    include "./tridiag_matmul_src/cnst_odiag.src"
  end subroutine tridiag_matmul_cnst_odiag_real_dp

  ! tridiag_matmul_cnst_offdiag definition for double-precision complex
  ! values
  subroutine tridiag_matmul_cnst_odiag_cmplx_dp(diag, u_diag_cnst, &
       l_diag_cnst, vec, res)
    complex(dp), intent(in) :: vec(:)
    complex(dp), intent(in) :: diag(size(vec))
    complex(dp), intent(in) :: u_diag_cnst, l_diag_cnst
    complex(dp), intent(inout) :: res(size(vec))

    include "./tridiag_matmul_src/cnst_odiag.src"
  end subroutine tridiag_matmul_cnst_odiag_cmplx_dp

  ! tridiag_matmul_cnst_offdiag definition for single-precision real values
  subroutine tridiag_matmul_cnst_odiag_real_sp(diag, u_diag_cnst, &
       l_diag_cnst, vec, res)
    real(sp), intent(in) :: vec(:)
    real(sp), intent(in) :: diag(size(vec))
    real(sp), intent(in) :: u_diag_cnst, l_diag_cnst
    real(sp), intent(inout) :: res(size(vec))

    include "./tridiag_matmul_src/cnst_odiag.src"
  end subroutine tridiag_matmul_cnst_odiag_real_sp

  ! tridiag_matmul_cnst_offdiag definition for single-precision complex
  ! values
  subroutine tridiag_matmul_cnst_odiag_cmplx_sp(diag, u_diag_cnst, &
       l_diag_cnst, vec, res)
    complex(sp), intent(in) :: vec(:)
    complex(sp), intent(in) :: diag(size(vec))
    complex(sp), intent(in) :: u_diag_cnst, l_diag_cnst
    complex(sp), intent(inout) :: res(size(vec))

    include "./tridiag_matmul_src/cnst_odiag.src"
  end subroutine tridiag_matmul_cnst_odiag_cmplx_sp

  ! subroutine tridiag_matmul_sym
  !
  ! Multiply symmetric tridiagonal matrix by vector
  !
  ! diag(n) :: diagonal entries
  ! o_diag(n - 1) :: off-diagonal entries
  ! vec(n) :: vector to multiply
  ! res(n) :: result of multiplication

  ! tridiag_matmul_sym definition for double-precision real valeus
  subroutine tridiag_matmul_sym_real_dp(diag, o_diag, vec, res)
    real(dp), intent(in) :: vec(:)
    real(dp), intent(in) :: diag(size(vec)), o_diag(size(vec) - 1)
    real(dp), intent(inout) :: res(size(diag))

    include "./tridiag_matmul_src/sym.src"
  end subroutine tridiag_matmul_sym_real_dp

  ! tridiag_matmul_sym definition for double-precision complex valeus
  subroutine tridiag_matmul_sym_cmplx_dp(diag, o_diag, vec, res)
    complex(dp), intent(in) :: vec(:)
    complex(dp), intent(in) :: diag(size(vec)), o_diag(size(vec) - 1)
    complex(dp), intent(inout) :: res(size(diag))

    include "./tridiag_matmul_src/sym.src"
  end subroutine tridiag_matmul_sym_cmplx_dp

  ! tridiag_matmul_sym definition for single-precision real valeus
  subroutine tridiag_matmul_sym_real_sp(diag, o_diag, vec, res)
    real(sp), intent(in) :: vec(:)
    real(sp), intent(in) :: diag(size(vec)), o_diag(size(vec) - 1)
    real(sp), intent(inout) :: res(size(diag))

    include "./tridiag_matmul_src/sym.src"
  end subroutine tridiag_matmul_sym_real_sp

  ! tridiag_matmul_sym definition for double-precision complex valeus
  subroutine tridiag_matmul_sym_cmplx_sp(diag, o_diag, vec, res)
    complex(sp), intent(in) :: vec(:)
    complex(sp), intent(in) :: diag(size(vec)), o_diag(size(vec) - 1)
    complex(sp), intent(inout) :: res(size(diag))

    include "./tridiag_matmul_src/sym.src"
  end subroutine tridiag_matmul_sym_cmplx_sp

  ! subroutine tridiag_matmul_syn_cnst
  !
  ! Multiply symmetric tridiagonal matrix by vector, where the band elements
  ! equal, band-wise
  !
  ! diag_cnst :: diagonal entry
  ! o_diag_cnst :: off-diagonal entry
  ! vec(n) :: vectory to multiply
  ! res(n) :: result of multiplication

  ! tridiag_matmul_sym_cnst definition for double-precision real values
  subroutine tridiag_matmul_sym_cnst_real_dp(diag_cnst, o_diag_cnst, vec, res)
    real(dp), intent(in) :: vec(:)
    real(dp), intent(in) :: diag_cnst, o_diag_cnst
    real(dp), intent(inout) :: res(size(vec))

    include "./tridiag_matmul_src/sym_cnst.src"
  end subroutine tridiag_matmul_sym_cnst_real_dp

  ! tridiagonal_matmul_sym_cnst definition for double-precision complex values
  subroutine tridiag_matmul_sym_cnst_cmplx_dp(diag_cnst, o_diag_cnst, vec, res)
    complex(dp), intent(in) :: vec(:)
    complex(dp), intent(in) :: diag_cnst, o_diag_cnst
    complex(dp), intent(inout) :: res(size(vec))

    include "./tridiag_matmul_src/sym_cnst.src"
  end subroutine tridiag_matmul_sym_cnst_cmplx_dp

  ! tridiag_matmul_sym_cnst definition for single-precision real values
  subroutine tridiag_matmul_sym_cnst_real_sp(diag_cnst, o_diag_cnst, vec, res)
    real(sp), intent(in) :: vec(:)
    real(sp), intent(in) :: diag_cnst, o_diag_cnst
    real(sp), intent(inout) :: res(size(vec))

    include "./tridiag_matmul_src/sym_cnst.src"
  end subroutine tridiag_matmul_sym_cnst_real_sp

  ! tridiagonal_matmul_sym_cnst definition for single-precision complex values
  subroutine tridiag_matmul_sym_cnst_cmplx_sp(diag_cnst, o_diag_cnst, vec, res)
    complex(sp), intent(in) :: vec(:)
    complex(sp), intent(in) :: diag_cnst, o_diag_cnst
    complex(sp), intent(inout) :: res(size(vec))

    include "./tridiag_matmul_src/sym_cnst.src"
  end subroutine tridiag_matmul_sym_cnst_cmplx_sp

  ! subroutine tridiag_matmul_sym_cnst_diag
  !
  ! Multiply symmetric tridiagonal matrix by a vector, where the diagonal
  ! elements are equal
  !
  ! diag_cnst :: diagonal element
  ! o_diag(n - 1) :: off-diagonal elements
  ! vec(n) :: vector to multiply
  ! res(n) :: result of multiplications

  ! tridiag_matmul_sym_cnst_diag definition for double-precision real values
  subroutine tridiag_matmul_sym_cnst_diag_real_dp(diag_cnst, o_diag, vec, res)
    real(dp), intent(in) :: vec(:)
    real(dp), intent(in) :: diag_cnst, o_diag(size(vec) - 1)
    real(dp), intent(inout) :: res(size(vec))

    include "./tridiag_matmul_src/sym_cnst_diag.src"
  end subroutine tridiag_matmul_sym_cnst_diag_real_dp

  ! tridiag_matmul_sym_cnst_diag definition for double-precision complex values
  subroutine tridiag_matmul_sym_cnst_diag_cmplx_dp(diag_cnst, o_diag, vec, res)
    complex(dp), intent(in) :: vec(:)
    complex(dp), intent(in) :: diag_cnst, o_diag(size(vec) - 1)
    complex(dp), intent(inout) :: res(size(vec))

    include "./tridiag_matmul_src/sym_cnst_diag.src"
  end subroutine tridiag_matmul_sym_cnst_diag_cmplx_dp

  ! tridiag_matmul_sym_cnst_diag definition for single-precision real values
  subroutine tridiag_matmul_sym_cnst_diag_real_sp(diag_cnst, o_diag, vec, res)
    real(sp), intent(in) :: vec(:)
    real(sp), intent(in) :: diag_cnst, o_diag(size(vec) - 1)
    real(sp), intent(inout) :: res(size(vec))

    include "./tridiag_matmul_src/sym_cnst_diag.src"
  end subroutine tridiag_matmul_sym_cnst_diag_real_sp

  ! tridiag_matmul_sym_cnst_diag definition for single-precision complex values
  subroutine tridiag_matmul_sym_cnst_diag_cmplx_sp(diag_cnst, o_diag, vec, res)
    complex(sp), intent(in) :: vec(:)
    complex(sp), intent(in) :: diag_cnst, o_diag(size(vec) - 1)
    complex(sp), intent(inout) :: res(size(vec))

    include "./tridiag_matmul_src/sym_cnst_diag.src"
  end subroutine tridiag_matmul_sym_cnst_diag_cmplx_sp

  ! subroutine tridiag_matmul_sym_cnst_odiag
  !
  ! Multiply symmetric tridiagonal matrix by a vector, where the off-diagonal
  ! elements are equal, band-wise
  !
  ! diag(n) :: diagonal elements
  ! o_diag_cnst :: off-diagonal element
  ! vec(n) :: vector to multiply
  ! res(n) :: result of multiplications

  ! tridiag_matmul_sym_cnst_odiag definition for double-precision real values
  subroutine tridiag_matmul_sym_cnst_odiag_real_dp(diag, o_diag_cnst, vec, res)
    real(dp), intent(in) :: vec(:)
    real(dp), intent(in) :: diag(size(vec)), o_diag_cnst
    real(dp), intent(inout) :: res(size(vec))

    include "./tridiag_matmul_src/sym_cnst_odiag.src"
  end subroutine tridiag_matmul_sym_cnst_odiag_real_dp

  ! tridiag_matmul_sym_cnst_odiag definition for double-precision complex
  ! values
  subroutine tridiag_matmul_sym_cnst_odiag_cmplx_dp(diag, o_diag_cnst, vec, &
       res)
    complex(dp), intent(in) :: vec(:)
    complex(dp), intent(in) :: diag(size(vec)), o_diag_cnst
    complex(dp), intent(inout) :: res(size(vec))

    include "./tridiag_matmul_src/sym_cnst_odiag.src"
  end subroutine tridiag_matmul_sym_cnst_odiag_cmplx_dp

  ! tridiag_matmul_sym_cnst_odiag definition for single-precision real values
  subroutine tridiag_matmul_sym_cnst_odiag_real_sp(diag, o_diag_cnst, vec, res)
    real(sp), intent(in) :: vec(:)
    real(sp), intent(in) :: diag(size(vec)), o_diag_cnst
    real(sp), intent(inout) :: res(size(vec))

    include "./tridiag_matmul_src/sym_cnst_odiag.src"
  end subroutine tridiag_matmul_sym_cnst_odiag_real_sp

  ! tridiag_matmul_sym_cnst_odiag definition for single-precision complex
  ! values
  subroutine tridiag_matmul_sym_cnst_odiag_cmplx_sp(diag, o_diag_cnst, vec, &
       res)
    complex(sp), intent(in) :: vec(:)
    complex(sp), intent(in) :: diag(size(vec)), o_diag_cnst
    complex(sp), intent(inout) :: res(size(vec))

    include "./tridiag_matmul_src/sym_cnst_odiag.src"
  end subroutine tridiag_matmul_sym_cnst_odiag_cmplx_sp

end module tridiag_matmul


!##############################################################################
!# ****************************************************************************
!# <name> codire </name>
!# ****************************************************************************
!#
!# <purpose>
!# This program is a simple test program for discretising the equation
!#
!#     - div ( alpha*grad(u) )  +  beta*grad(u)  +  gamma*u  =  f
!#
!# on a 2D domain for a scalar function u.
!#
!# The main example (module codire_method3) separates the different stages
!# of the solution process into different subroutines like example 2.
!# The communication is done using a problem-related structure. For the
!# communication with callback routines during the assembly, a
!# collection structure is set up.
!#
!# The second example (module codire_method3) shows how to use a Multigrid
!# solver to solve the problem. Besides that, the module is similar to
!# codire_method3.
!#
!# The equation itself is set up using parameters of a .DAT file
!# named 'data/codire.dat'. Here all parameters (alpha, beta, gamma, level,...)
!# can be found and changed by the user without recompiling the program.
!# </purpose>
!##############################################################################

program codire

  use codire_method3
  use codire_method5

  implicit none

  ! local variables
  character(len=SYS_STRLEN) :: slogdir,slogfile

  ! The very first thing in every application:
  ! Initialise system-wide settings:

  call sys_init()

  ! Initialise the output system.
  !
  ! Normally, we write all the output to the screen and to a file
  ! './log/output.txt'.
  ! In the case that environment variables "$logdir"/"$resultsfile" exists,
  ! we write all the output to that file. This can be used e.g. in
  ! regression tests to compare results to reference results.
  if (sys_getenv_string('LOGDIR',slogdir) .and. &
      sys_getenv_string('RESULTFILE',slogfile)) then
    call output_init (trim(slogdir)//'/'//trim(slogfile))
  else
    call output_init ('./log/output.txt')
  end if

  ! The very second thing in every program:
  ! Initialise the storage management:
  !
  ! Initialise FEAT 2.0 storage management:
  call storage_init(999, 100)

  ! Call the problem to solve.
  print *
  print *,'Calculating CoDiRe-Problem with method 3'
  print *,'----------------------------------------'
  call codire3

  ! Call the problem to solve - method 5 = multigrid
  print *
  print *,'Calculating CoDiRe-Problem with method 5'
  print *,'----------------------------------------'
  call codire5

  ! Print out heap statistics - just to check if everything
  ! is cleaned up.
  ! This should display 'Handles in use=0' and 'Memory in use=0'!
  call output_lbrk()
  call storage_info(.true.)

  ! Clean up the storage management, finish
  call output_done()
  call storage_done()

end program


*dk,hpsortimp
      SUBROUTINE hpsortimp(n,m,md,ia,ascend,iprm)
C
C
C#######################################################################
C
C     PURPOSE -
C
C     HPSORTIMP ("HeaP SORT using an Integer M-fold key, generating
C     a Permution array") takes an integer N, an integer array IA, with
C     first dimension length MD and second dimension length N, an integer
C     permutation array IPRM of length N, and a real number ASCEND, and
C     reorders IPRM so that IA(1,IPRM(1)),...,IA(1,IPRM(N))
C     is in ascending order if ASCEND is positive and
C     is in decreasing order if ASCEND is negative.  To
C     break ties, we require also that IA(2,IPRM(*)) is
C     in ascending (descending) order, and so on, until
C     possibly the M'th key IA(M,*) is consulted
C     (i.e. ascending lexicographic order of M-tuples).
C     Of course this requires that M<=MD.
C
C     INPUT ARGUMENTS -
C
C        N - number of elements to be sorted.
C        M - we interpret array IA as M-tuples
C        MD- actual first dimension of array IA (M<=MD)
C        IA - integer array of values which determine
C             how IPRM will be reordered, it has 'depth' M for
C             purposes of tie-breaking
C        IPRM - integer array to be reordered.  Strictly
c             speaking, IPRM need not be a permutation of
c             the integers {1,..,N}, but may be simply
c             a mapping from {1,..,N} onto a set of N
c             distinct positive integers.
C        ASCEND - real*8 which controls whether we sort in ascending
C                 or descending order.
C
C     OUTPUT ARGUMENTS -
C
C        IPRM - reordered integer array.
C
C     CHANGE HISTORY -
C
C        $Log: hpsortimp.f,v $
C        Revision 2.00  2007/11/03 00:49:11  spchu
C        Import to CVS
C
CPVCS
CPVCS       Rev 1.0   08 May 2001 10:29:56   dcg
CPVCS    Initial revision.
CPVCS
CPVCS       Rev 1.0   Tue Aug 24 21:57:34 1999   kuprat
CPVCS    Initial revision.
C
C#######################################################################
C

      implicit none

      INTEGER n,m,md
      INTEGER ia(md,*)
      REAL*8 ascend
      INTEGER i,ir,j,l,iprm(n),irra,k
      if (n.lt.2) return
      l=n/2+1
      ir=n
10    continue
        if(l.gt.1)then
          l=l-1
          irra=iprm(l)
        else
          irra=iprm(ir)
          iprm(ir)=iprm(1)
          ir=ir-1
          if(ir.eq.1)then
            iprm(1)=irra
            return
          endif
        endif
        i=l
        j=l+l
20      if(j.le.ir)then
          if(j.lt.ir)then
            do k=1,m-1
              if(ascend*ia(k,iprm(j)).lt.ascend*ia(k,iprm(j+1))) then
                j=j+1
                goto 30
              elseif(ascend*ia(k,iprm(j)).gt.ascend*ia(k,iprm(j+1)))then
                goto 30
              endif
            enddo
            if(ascend*ia(m,iprm(j)).lt.ascend*ia(m,iprm(j+1)))j=j+1
          endif
 30       continue
          do k=1,m-1
            if(ascend*ia(k,irra).lt.ascend*ia(k,iprm(j))) then
              iprm(i)=iprm(j)
              i=j
              j=j+j
              goto 20
            elseif(ascend*ia(k,irra).gt.ascend*ia(k,iprm(j))) then
              j=ir+1
              goto 20
            endif
          enddo
          if(ascend*ia(m,irra).lt.ascend*ia(m,iprm(j))) then
            iprm(i)=iprm(j)
            i=j
            j=j+j
          else
            j=ir+1
          endif
          goto 20
        endif
        iprm(i)=irra
      goto 10
      END