subroutine tish(re,ratc,ratl,tlen,np,omegai,imin,imax, &
   nzone,vrmin,vrmax,rrho,vsv,vsh,qmu, &
   r0,eqlat,eqlon,mt,nr,theta,phi,lat,lon,output,write_to_file, &
   outputu)
!------------------------------------------------------------------------
!  ************** tish.f ****************
! Computation of SH synthetic seismograms
! in transversely isotropic media for anisotropic PREM
! using modified DSM operators & modified source representation.
! Synthetics for shallow events can be computed.
!
!                                                 2002.10 K.Kawai
!------------------------------------------------------------------------
    use parameters
    implicit none
! ----------------------------<<variables>>----------------------------
! write to files?
    logical, intent(in) :: write_to_file
! variable for the trial function
    integer nnlayer,nlayer(maxnzone)
    integer l,m
    real(dp) ra(maxnlay+maxnzone+1),gra(3),plm(3,0:3,maxnr)
    complex(dp) bvec(3,-2:2,maxnr)
! variable for the structure
    integer, intent(in) :: nzone
    integer ndc,vnp
    real(dp) rmin,rmax
    real(dp), intent(in) :: vrmin(maxnzone),vrmax(maxnzone)
    real(dp), intent(in) :: rrho(4,maxnzone),vsv(4,maxnzone),vsh(4,maxnzone)
    real(dp), intent(in) :: qmu(maxnzone)
    real(dp) vra(maxnlay+2*maxnzone+1)
    real(dp) rho(maxnlay+2*maxnzone+1)
    real(dp) ecL(maxnlay+2*maxnzone+1)
    real(dp) ecN(maxnlay+2*maxnzone+1)
    real(dp) gvra(3),grho(3),gecL(3),gecN(3)
    complex(dp) coef(maxnzone)
! variable for the periodic range
    integer, intent(in) :: np,imin,imax
    real(dp), intent(in) :: tlen,omegai
    complex(dp):: comega2
    real(dp) omega
    complex(dp) u(3,maxnr)
! variable for the source
    integer spn,ns
    real(dp), intent(in) :: r0,mt(3,3),eqlat,eqlon
    real(dp) spo,mu0
! variable for the station
    integer, intent(in) :: nr
    integer ir
    real(dp), intent(in) :: theta(maxnr),phi(maxnr)
    real(dp), intent(in) :: lat(maxnr),lon(maxnr)
! variable for the matrix elements
    complex(dp) a0( 2,maxnlay+1 ), a2( 2,maxnlay+1 )
    complex(dp)  a( 2,maxnlay+1 )
    real(dp) t( 4*maxnlay )
    real(dp) h1( 4*maxnlay ),h2( 4*maxnlay )
    real(dp) h3( 4*maxnlay ),h4( 4*maxnlay )
    real(dp) gt(8),gh1(8),gh2(8),gh3(8),gh4(8)
    complex(dp) aa(4),ga(8),ga2(2,3),gdr(3)
    complex(dp) g( maxnlay+1 )
! variable for the file
    character*80, intent(in) :: output(maxnr)
! variable for grid spacing
    real(dp) tmpr(maxnlay+1)
    real(dp) gridpar(maxnzone),dzpar(maxnzone),vmin(maxnzone)
    real(dp), intent(in) :: re,ratc,ratl
    real(dp) maxamp
    integer kc,lsuf,ismall,llog
! variable for the stack point
    integer isp(maxnzone),jsp(maxnzone),ins
! other variables
    integer i,j,ii,jj,nn,ier
    real(dp) eps,work( 4*maxnlay ),lsq
    complex(dp) dr(maxnlay+1),z(maxnlay+1)
    complex(dp) cwork( 4*maxnlay )
    integer ltmp(2),iimax

    integer,parameter:: lda=2
    data eps/ -1.d0 /

    complex(dp), intent(out) :: outputu(3,nr,imin:imax)

! --- computing the required parameters ---
! computing and checking the parameters
    rmin = vrmin(1)
    rmax = vrmax(nzone)
    ndc = nzone - 1

    if ( r0 < rmin .or. r0 > rmax ) then
        write(*,*) 'Location of the source is improper.'
        return
    endif

! --------------------------------------------------------------------
    iimax = imax
    if( (rmax-r0) < shallowdepth) then ! option for shallow events
! computing of the number and the location of grid points
        iimax = int(tlen * 2)
        call calgrid( nzone,vrmin,vrmax,vsv,rmin,rmax, &
            iimax,1,tlen,vmin,gridpar,dzpar )
        call calra ( nnlayer,gridpar,dzpar,nzone,vrmin,vrmax, &
            rmin,rmax,nlayer,ra,re )
! --- checking the parameter
        if ( nnlayer>maxnlay ) then
            write(*,*) 'The number of grid points is too large.'
            return
        endif
! computing the stack points
        call calsp( ndc,nlayer,isp,jsp )
! computing the source location
        call calspo( ndc,vrmax,nnlayer,r0,rmin,rmax,ra,isp,spo,spn )
! computing grids for source computations
        call calgra( isp,ra,r0,spn,spo,gra )
! ******************* Computing the matrix elements *******************
! computing the structure grid points
        call calstg( nzone,rrho,vsv,vsh, nnlayer,nlayer,ra,rmax, &
        vnp,vra,rho,ecL,ecN)
        call calgstg( spn,rrho,vsv,vsh,gra,gvra,rmax,grho,gecL,gecN,r0,mu0 )
        do i=1,ndc+1
            call calmatc( nlayer(i),vnp,vra,rho,2,0,0,ra( isp(i) ),t( jsp(i) ),work( jsp(i) ) )
            call calmatc( nlayer(i),vnp,vra,ecL,2,1,1,ra( isp(i) ),h1( jsp(i) ),work( jsp(i) ) )
            call calmatc( nlayer(i),vnp,vra,ecL,1,1,0,ra( isp(i) ),h2( jsp(i) ),work( jsp(i) ) )
            call calmatc( nlayer(i),vnp,vra,ecL,0,0,0,ra( isp(i) ),h3( jsp(i) ),work( jsp(i) ) )
            call calmatc( nlayer(i),vnp,vra,ecN,0,0,0,ra( isp(i) ),h4( jsp(i) ),work( jsp(i) ) )
            call caltl( nlayer(i),vnp,vra,rho,ra( isp(i) ),work( jsp(i) ) )
            t(jsp(i):jsp(i)+4*nlayer(i)-1)=(t(jsp(i):jsp(i)+4*nlayer(i)-1)&
             +work(jsp(i):jsp(i)+4*nlayer(i)-1))/2
            call calhl( nlayer(i),vnp,vra,ecL,ra( isp(i) ),work( jsp(i) ) )
            h3(jsp(i):jsp(i)+4*nlayer(i)-1)=(h3(jsp(i):jsp(i)+4*nlayer(i)-1)&
             +work(jsp(i):jsp(i)+4*nlayer(i)-1))/2
            call calhl( nlayer(i),vnp,vra,ecN,ra( isp(i) ),work( jsp(i) ) )
            h4(jsp(i):jsp(i)+4*nlayer(i)-1)=(h4(jsp(i):jsp(i)+4*nlayer(i)-1)&
             +work(jsp(i):jsp(i)+4*nlayer(i)-1))/2
        enddo
        call calmatc( 2,3,gvra,grho,2,0,0,gra,gt, work )
        call calmatc( 2,3,gvra,gecL ,2,1,1,gra,gh1,work )
        call calmatc( 2,3,gvra,gecL ,1,1,0,gra,gh2,work )
        call calmatc( 2,3,gvra,gecL ,0,0,0,gra,gh3,work )
        call calmatc( 2,3,gvra,gecN ,0,0,0,gra,gh4,work )
        call caltl( 2,3,gvra,grho,gra,work )
        gt(1:8)=(gt(1:8)+work(1:8))/2

        call calhl( 2,3,gvra,gecL, gra,work )
        gh3(1:8)=(gh3(1:8)+work(1:8))/2

        call calhl( 2,3,gvra,gecN, gra,work )
        gh4(1:8)=(gh4(1:8)+work(1:8))/2

        nn = nnlayer + 1
        ns = isp(spn) + dint(spo)
        ins = 4 * ns - 3

        llog = 0
        do ii=1,2 ! omega-loop
            if(ii==1) then
                if(imin==0) then
                    i=1
                else
                    i=imin
                endif
            endif
            if(ii==2) i=imax
            omega = 2 * pi * dble(i) / tlen
            comega2 = dcmplx( omega, -omegai ) * dcmplx( omega, -omegai )

            call callsuf(omega,nzone,vrmax,vsv,lsuf)
            call calcoef( nzone,omega,qmu,coef )

            a0(1:lda,1:nn)=0
            a2(1:lda,1:nn)=0
            do j=1,ndc+1
                !cala0
                cwork(jsp(j):jsp(j)+4*nlayer(j)-1)= comega2*(t(jsp(j):jsp(j)+4*nlayer(j)-1))&
                -coef(j)*(h1(jsp(j):jsp(j)+4*nlayer(j)-1)-h2(jsp(j):jsp(j)+4*nlayer(j)-1)&
                +h3(jsp(j):jsp(j)+4*nlayer(j)-1)-2*h4(jsp(j):jsp(j)+4*nlayer(j)-1))
                call overlap( nlayer(j),cwork(jsp(j)),a0( 1,isp(j) ) )
                !cala2
                cwork(jsp(j):jsp(j)+4*nlayer(j)-1)=-coef(j)* h4(jsp(j):jsp(j)+4*nlayer(j)-1)
                call overlap( nlayer(j),cwork(jsp(j)),a2( 1,isp(j) ) )
            enddo

            kc = 1
            ismall = 0
            maxamp = -1
            ltmp(ii) = maxlmax
            do l=0,maxlmax ! l-loop
                if( ismall>20 ) then
                    if(ltmp(ii)>l) ltmp(ii) = l
                    exit
                endif

               ! initialize
                tmpr(1:maxnlay+1) = 0.d0
                lsq = dsqrt( l*(l+1d0) )
! computing the coefficient matrix elements
! --- Initializing the matrix elements
                a(1:lda,1:nn)=0
                ga2(1:lda,1:3)=0

                ! Computing the coefficient matrix 'a' in the solid part. cala
                a(1:2,1:nn) = a0(1:2,1:nn) + l*(l+1) * a2(1:2,1:nn)

                !c Computing the coefficient matrix 'a' in the solid part. calga
                aa(1:4) = comega2 * t(ins:ins+3)&
                - coef(spn) * ( h1(ins:ins+3)-h2(ins:ins+3)+h3(ins:ins+3)+dble(l*(l+1)-2)*h4(ins:ins+3) )
                ga(1:8)=comega2*gt(1:8)&
                - coef(spn)*( gh1(1:8)-gh2(1:8)+gh3(1:8)+(l*(l+1)-2)*gh4(1:8) )

                call overlap( 2,ga,ga2 )

                do m=-2,2 ! m-loop
                    if (  m/=0 .and. iabs(m)<=iabs(l) ) then
                        g(1:nn)=0
                        call calg2( l,m,spo,r0,mt,mu0,coef(spn),ga,aa,ga2,gdr,g(isp(spn)) )
                        if( mod(l,100)==0) then
                            if ( m==-2 .or. m==-l ) then
                                call dclisb0( a,nn,1,lda,g,eps,dr,z,ier)
                            else
                                call dcsbsub0( a,nn,1,lda,g,eps,dr,z,ier)
                            endif
                            !sum up c of the same l
                            tmpr(1:nn) = tmpr(1:nn) + cdabs(g(1:nn))
                        else
                            if ( m==-2 .or. m==-l ) then
                                call dclisb( a(1,kc),nn-kc+1,1,lda,ns-kc+1 &
                                     ,g(kc),eps,dr,z,ier)
                            else
                                call dcsbsub( a(1,kc),nn-kc+1,1,lda,ns-kc+1 &
                                     ,g(kc),eps,dr,z,ier)
                            endif
                        endif

                        if( mod(l,100)==0) call calcutd(nzone,nlayer,tmpr,ratc,nn,ra,kc)
                        call calamp(g(nn),l,lsuf,maxamp,ismall,ratl)
                    endif
                enddo ! m-loop
            enddo ! l-loop
        enddo ! omega-loop
        iimax = dble(max(ltmp(1),ltmp(2))) * tlen / lmaxdivf
    endif ! option for shallow events

! computing of the number and the location of grid points
    call calgrid( nzone,vrmin,vrmax,vsv,rmin,rmax,iimax,1,tlen,vmin,gridpar,dzpar )
    call calra ( nnlayer,gridpar,dzpar,nzone,vrmin,vrmax,rmin,rmax,nlayer,ra,re )
! --- checking the parameter
    if ( nnlayer>maxnlay ) then
        write(*,*) 'The number of grid points is too large.'
        return
    endif
! computing the stack points
    call calsp( ndc,nlayer,isp,jsp )
! computing the source location
    call calspo( ndc,vrmax,nnlayer,r0,rmin,rmax,ra,isp,spo,spn )
! computing grids for source computations
    call calgra( isp,ra,r0,spn,spo,gra )
! ******************* Computing the matrix elements *******************
! computing the structure grid points
    call calstg( nzone,rrho,vsv,vsh,nnlayer,nlayer,ra,rmax,vnp,vra,rho,ecL,ecN)
    call calgstg( spn,rrho,vsv,vsh,gra,gvra,rmax,grho,gecL,gecN,r0,mu0 )
    do i=1,ndc+1
        call calmatc( nlayer(i),vnp,vra,rho,2,0,0,ra( isp(i) ),t( jsp(i) ),work( jsp(i) ) )
        call calmatc( nlayer(i),vnp,vra,ecL,2,1,1,ra( isp(i) ),h1( jsp(i) ),work( jsp(i) ) )
        call calmatc( nlayer(i),vnp,vra,ecL,1,1,0,ra( isp(i) ),h2( jsp(i) ),work( jsp(i) ) )
        call calmatc( nlayer(i),vnp,vra,ecL,0,0,0,ra( isp(i) ),h3( jsp(i) ),work( jsp(i) ) )
        call calmatc( nlayer(i),vnp,vra,ecN,0,0,0,ra( isp(i) ),h4( jsp(i) ),work( jsp(i) ) )
        call caltl( nlayer(i),vnp,vra,rho,ra(isp(i)),work( jsp(i) ) )
        t(jsp(i):jsp(i)+4*nlayer(i)-1)=(t(jsp(i):jsp(i)+4*nlayer(i)-1)&
             +work(jsp(i):jsp(i)+4*nlayer(i)-1))/2
        call calhl( nlayer(i),vnp,vra,ecL,ra( isp(i) ),work( jsp(i) ) )
        h3(jsp(i):jsp(i)+4*nlayer(i)-1)=(h3(jsp(i):jsp(i)+4*nlayer(i)-1)&
             +work(jsp(i):jsp(i)+4*nlayer(i)-1))/2
        call calhl( nlayer(i),vnp,vra,ecN,ra( isp(i) ),work( jsp(i) ) )
        h4(jsp(i):jsp(i)+4*nlayer(i)-1)=(h4(jsp(i):jsp(i)+4*nlayer(i)-1)&
             +work(jsp(i):jsp(i)+4*nlayer(i)-1))/2
    enddo
    call calmatc(2,3,gvra,grho,2,0,0,gra,gt, work)
    call calmatc(2,3,gvra,gecL,2,1,1,gra,gh1,work)
    call calmatc(2,3,gvra,gecL,1,1,0,gra,gh2,work)
    call calmatc(2,3,gvra,gecL,0,0,0,gra,gh3,work)
    call calmatc(2,3,gvra,gecN,0,0,0,gra,gh4,work)
    call caltl( 2,3,gvra,grho,gra,work )
    gt(1:8)=(gt(1:8)+work(1:8))/2

    call calhl( 2,3,gvra,gecL,gra,work )
    gh3(1:8)=(gh3(1:8)+work(1:8))/2

    call calhl( 2,3,gvra,gecN,gra,work )
    gh4(1:8)=(gh4(1:8)+work(1:8))/2

! ******************** Computing the displacement *********************
    nn = nnlayer + 1
    ns = isp(spn) + dint(spo)
    ins = 4 * ns - 3

    llog = 0
    do i=imin,imax ! omega-loop
        u( 1:3,1:nr )=0

        if ( i/=0 ) then
            omega = 2 * pi * i / tlen
            comega2 = dcmplx( omega, -omegai ) * dcmplx( omega, -omegai )
            call callsuf(omega,nzone,vrmax,vsv,lsuf)

            plm(1:3,0:3,1:nr)=0

            call calcoef( nzone,omega,qmu,coef )

            a0( 1:lda,1:nn )=0
            a2( 1:lda,1:nn )=0
            do j=1,ndc+1
!cala0
                cwork(jsp(j):jsp(j)+4*nlayer(j)-1)= comega2*(t(jsp(j):jsp(j)+4*nlayer(j)-1))&
                -coef(j)*(h1(jsp(j):jsp(j)+4*nlayer(j)-1)-h2(jsp(j):jsp(j)+4*nlayer(j)-1)&
                +h3(jsp(j):jsp(j)+4*nlayer(j)-1)-2d0*h4(jsp(j):jsp(j)+4*nlayer(j)-1))
                call overlap( nlayer(j),cwork(jsp(j)),a0( 1,isp(j) ) )
                cwork(jsp(j):jsp(j)+4*nlayer(j)-1)=-coef(j)*( h4(jsp(j):jsp(j)+4*nlayer(j)-1) )
                call overlap( nlayer(j),cwork(jsp(j)),a2( 1,isp(j) ) )
            enddo

            kc = 1
            ismall = 0
            maxamp = -1
            llog = maxlmax
            do l=0,maxlmax ! l-loop
                if( ismall>20 ) then
                    if(llog>l) llog = l
                    cycle
                endif

                tmpr(1:maxnlay+1) = 0
                lsq = dsqrt( l*(l+1d0) )
! ***** Computing the trial function *****
                do ir=1,nr
                    call calbvec( l,theta(ir),phi(ir),plm(1,0,ir),bvec(1,-2,ir) )
                enddo
! computing the coefficient matrix elements
                a(1:lda,1:nn)=0
                ga2(1:lda,1:3)=0

                !c Computing the coefficient matrix 'a' in the solid part. cala
                a(1:2,1:nn) = a0(1:2,1:nn) + l*(l+1) * a2(1:2,1:nn)

                !c Computing the coefficient matrix 'a' in the solid part. calga
                aa(1:4)=comega2*t(ins:ins+3)-coef(spn)*(h1(ins:ins+3)-h2(ins:ins+3)+h3(ins:ins+3)+(l*(l+1)-2)*h4(ins:ins+3))
                ga(1:8)=comega2*gt(1:8)- coef(spn)*( gh1(1:8)-gh2(1:8)+gh3(1:8)+(l*(l+1)-2)*gh4(1:8))
                call overlap( 2,ga,ga2 )

                do m=-2,2 ! m-loop
                    if ( m/=0 .and. iabs(m)<=iabs(l) ) then
                        g(1:nn)=0
                        call calg2( l,m,spo,r0,mt,mu0,coef(spn),ga,aa,ga2,gdr,g( isp(spn) ) )
                        if( mod(l,100)==0) then
                            if ( m==-2 .or. m==-l ) then
                                call dclisb0( a,nn,1,lda,g,eps,dr,z,ier)
                            else
                                call dcsbsub0( a,nn,1,lda,g,eps,dr,z,ier)
                            endif
                            tmpr(1:nn) = tmpr(1:nn) + cdabs(g(1:nn))
                        else
                            if ( m==-2 .or. m==-l ) then
                                call dclisb( a(1,kc),nn-kc+1,1,lda,ns-kc+1 &
                                ,g(kc),eps,dr,z,ier)
                            else
                                call dcsbsub( a(1,kc),nn-kc+1,1,lda,ns-kc+1 &
                                 ,g(kc),eps,dr,z,ier)
                            endif
                        endif

                        if( mod(l,100)==0) call calcutd(nzone,nlayer,tmpr,ratc,nn,ra,kc)

                        call calamp(g(nn),l,lsuf,maxamp,ismall,ratl)
                        u(2:3,1:nr) = u(2:3,1:nr) + g(nn) * bvec(2:3,m,1:nr) / lsq
                    endif
                enddo          ! m-loop
            enddo             ! l-loop
        endif
! ************************** Files Handling **************************
        outputu(1:3,1:nr,i) = u(1:3,1:nr)
    enddo                   ! omega-loop

    if (write_to_file) then
        write(*,*) "kakikomimasu"
        do ir = 1 ,nr
            open(1,file=output(ir),status='replace',access='stream',form='unformatted', convert='big_endian')
            write(1) tlen,np,1,3,omegai,lat(ir),lon(ir),eqlat,eqlon,r0

            do i= imin, imax
                write(1) i,dble(outputu(1,ir,i)),dimag(outputu(1,ir,i))
                write(1) dble(outputu(2,ir,i)),dimag(outputu(2,ir,i))
                write(1) dble(outputu(3,ir,i)),dimag(outputu(3,ir,i))
            enddo
            close(1)
        enddo
    endif
    return
end subroutine tish

program main

   use parameters
   implicit none

   character(len=160) :: parameter_file

   integer np
   integer imin
   integer imax
   integer nzone
   integer nr
   real(dp) :: tlen
   real(dp) :: omegai
   real(dp) :: re
   real(dp) :: ratc
   real(dp) :: ratl
   real(dp) :: vrmin(maxnzone)
   real(dp) :: vrmax(maxnzone)
   real(dp) :: qmu(maxnzone)
   real(dp) :: rho(4,maxnzone)
   real(dp) :: vsv(4,maxnzone)
   real(dp) :: vsh(4,maxnzone)
   real(dp) :: r0
   real(dp) :: mt(3,3)
   real(dp) :: lat(maxnr)
   real(dp) :: lon(maxnr)
   real(dp) :: theta(maxnr)
   real(dp) :: phi(maxnr)
   real(dp) :: eqlat
   real(dp) :: eqlon
   character(len=80) :: output(maxnr)
   complex(dp), allocatable, dimension(:,:,:) :: outputu
   logical :: write_to_file = .true.

   ! read input parameters
   call get_command_argument(1, parameter_file)
   call pinput_tish(parameter_file, &
      re,ratc,ratl,tlen,np,omegai,imin,imax, &
      nzone,vrmin,vrmax,rho,vsv,vsh,qmu, &
      r0,eqlat,eqlon,mt,nr,theta,phi,lat,lon,output)

   allocate(outputu(3,nr,imin:imax))

   ! main loop
   write(*,*) 'Enter main loop'
   call tish(re,ratc,ratl,tlen,np,omegai,imin,imax, &
      nzone,vrmin,vrmax,rho,vsv,vsh,qmu, &
      r0,eqlat,eqlon,mt,nr,theta,phi,lat,lon,output,write_to_file,outputu)
   write(*,*) 'Done!'

end program main


! ###################################################################
! Copyright (c) 2015-2020, Marc De Graef Research Group/Carnegie Mellon University
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without modification, are
! permitted provided that the following conditions are met:
!
!     - Redistributions of source code must retain the above copyright notice, this list
!        of conditions and the following disclaimer.
!     - Redistributions in binary form must reproduce the above copyright notice, this
!        list of conditions and the following disclaimer in the documentation and/or
!        other materials provided with the distribution.
!     - Neither the names of Marc De Graef, Carnegie Mellon University nor the names
!        of its contributors may be used to endorse or promote products derived from
!        this software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
! ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
! LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
! USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
! ###################################################################

!--------------------------------------------------------------------------
! EMsoft:EMECPDictionaryIndexing.f90
!--------------------------------------------------------------------------
!
! PROGRAM: EMECPDictionaryIndexing
!
!> @author Saransh Singh, Carnegie Mellon University
!
!> @brief Indexing of ECP patterns using the dictionary approach.
!
!> @date 12/28/15 SS  1.0 original
!> @date 01/25/17 MDG 1.1 corrected template file numbering
!--------------------------------------------------------------------------

program ECPIndexing

use local
use NameListTypedefs
use NameListHandlers
use ECPmod
use json_module
use files
use error
use io

IMPLICIT NONE

character(fnlen)                                   :: nmldeffile, progname, progdesc
type(ECPIndexingNameListType)                      :: ecpnl
type(ECPLargeAccumType),pointer                    :: acc
type(ECPMasterType),pointer                        :: master
logical                                            :: verbose
integer(kind=irg)                                  :: istat, nsig, numk, i, res
integer(kind=irg),allocatable                      :: kij(:,:)
real(kind=sgl),allocatable                         :: anglewf(:), klist(:,:)
type(IncidentListECP),pointer                      :: khead, ktmp

interface
        subroutine MasterSubroutine(ecpnl,acc,master,kij,klist,anglewf,progname,nmldeffile)

        use local
        use typedefs
        use NameListTypedefs
        use NameListHandlers
        use files
        use dictmod
        use others, only: SSORT
        use crystal
        use initializers
        use gvectors
        use io
        use error
        use diffraction
        use symmetry
        use quaternions
        use constants
        use rotations
        use so3
        use math
        use ECPmod
        use clfortran
        use CLsupport
        use omp_lib
        use Indexingmod
        use ISO_C_BINDING

        IMPLICIT NONE

        type(ECPIndexingNameListType),INTENT(INOUT)        :: ecpnl
        type(ECPLargeAccumType),pointer,INTENT(IN)         :: acc
        type(ECPMasterType),pointer,Intent(IN)             :: master
        integer(kind=irg),INTENT(IN)                       :: kij(2,ecpnl%npix**2)
        real(kind=sgl),INTENT(IN)                          :: klist(3,ecpnl%npix**2)
        real(kind=sgl),INTENT(IN)                          :: anglewf(nint((ecpnl%thetac)+abs(ecpnl%sampletilt)) + 1)
        character(fnlen),INTENT(IN)                        :: progname
        character(fnlen),INTENT(IN)                        :: nmldeffile

        end subroutine MasterSubroutine
end interface

nmldeffile = 'EMECPDI.nml'
progname = 'EMECPDI.f90'
progdesc = 'Program to index channeling patterns using the dynamically calculated dictionary'
verbose = .TRUE.

! print some information
call EMsoft(progname, progdesc)

! deal with the command line arguments, if any
call Interpret_Program_Arguments(nmldeffile,1,(/ 72 /), progname)

! deal with the namelist stuff, either .nml or .json format
res = index(nmldeffile,'.nml',kind=irg)
if (res.eq.0) then
  call FatalError('EMECPIndexing','JSON input not yet implemented')
!  call JSONreadECPIndexingNameList(ecpnl, nmldeffile, error_cnt)
else
  call GetECPIndexingNameList(nmldeffile,ecpnl)
end if

! 1. read the Monte Carlo data file
allocate(acc)
call ECPIndexingreadMCfile(ecpnl, acc, verbose=.TRUE.)

! 2. read EBSD master pattern file
allocate(master)
call ECPIndexingreadMasterfile(ecpnl, master)

! 3. generate detector arrays and weight factors
call ECPIndexingGenerateDetector(ecpnl, master, verbose)

nsig = nint((ecpnl%thetac) + abs(ecpnl%sampletilt)) + 1
allocate(anglewf(1:nsig),stat=istat)

call ECPIndexingGetWeightFactors(ecpnl, master, acc, anglewf, nsig, verbose)

! 4. generate list of incident vectors and put them in array for OpenMP
numk = 0
call GetVectorsConeIndexing(ecpnl, khead, numk)
allocate(kij(2,numk),klist(3,numk),stat=istat)

ktmp => khead
! converting to array for OpenMP parallelization
do i = 1,numk
   klist(1:3,i) = ktmp%k(1:3)
   kij(1:2,i) = (/ktmp%i,ktmp%j/)
   ktmp => ktmp%next
end do

! perform the dictionary indexing computations
call MasterSubroutine(ecpnl,acc,master,kij,klist,anglewf,progname, nmldeffile)

deallocate(master, acc, klist, kij, anglewf)

end program ECPIndexing

!--------------------------------------------------------------------------------------------------------
!
! SUBROUTINE:MasterSubroutine
!
!> @author Saransh Singh, Carnegie Mellon University
!
!> @brief Master subroutine to control dictionary generation, inner products computations, sorting values
!> and indexing of points, all in parallel using OpenCL/openMP
!
!> @param ecpnl
!> @param master
!> @param acc
!> @param
!
!> @date 12/28/15  SS 1.0 original
!> @date 01/29/16 MDG 1.1 moved exp. pattern reading out of major loop for speedup
!> @date 01/30/16 MDG 1.2 no need to flip the patterns so removed some arrays
!> @date 01/30/16 MDG 1.3 use master thread to control GPU; loop simplifications to avoid code duplication
!> @date 01/31/16 MDG 1.4 added devid parameter to select the opencl device
!> @date 03/08/16 MDG 1.5 converted OpenCL calls to clfortran library
!> @date 03/16/17 SS  1.6 adding tmpfile as argument; adding h5 file as output; improving ctf write routine
!> @date 11/13/17 MDG 2.0 moved OpenCL code from InnerProdGPU routine to main code
!----------------------------------------------------------------------------------------------------------
subroutine MasterSubroutine(ecpnl, acc, master, kij, klist, anglewf, progname, nmldeffile)

use local
use typedefs
use NameListTypedefs
use NameListHandlers
use files
use dictmod
use others, only: SSORT
use crystal
use initializers
use gvectors
use io
use error
use diffraction
use symmetry
use quaternions
use constants
use rotations
use so3
use math
use filters
use ECPmod
use clfortran
use CLsupport
use distortion
use omp_lib
use Indexingmod
use HDF5
use HDFsupport
use ECPiomod
use ISO_C_BINDING

IMPLICIT NONE

character(fnlen),INTENT(IN)                        :: progname
character(fnlen),INTENT(IN)                        :: nmldeffile
type(ECPIndexingNameListType),INTENT(INOUT)        :: ecpnl
type(ECPLargeAccumType),pointer,INTENT(IN)         :: acc
type(ECPMasterType),pointer,INTENT(IN)             :: master
integer(kind=irg),INTENT(IN)                       :: kij(2,ecpnl%npix**2)
real(kind=sgl),INTENT(IN)                          :: klist(3,ecpnl%npix**2)
real(kind=sgl),INTENT(IN)                          :: anglewf(nint((ecpnl%thetac)+abs(ecpnl%sampletilt))+1)

integer(c_intptr_t),allocatable, target            :: platform(:)
integer(c_intptr_t),allocatable, target            :: device(:)
integer(c_intptr_t),target                         :: context
integer(c_intptr_t),target                         :: command_queue
integer(c_intptr_t),target                         :: cl_expt,cl_dict
character(len = 50000), target                     :: source
integer(kind=irg), parameter                       :: source_length = 50000
integer(kind=irg), target                          :: source_l
character(len=source_length, KIND=c_char),TARGET   :: csource
type(c_ptr), target                                :: psource
integer(c_int32_t)                                 :: ierr, ierr2, pcnt
integer(c_intptr_t),target                         :: prog
integer(c_intptr_t),target                         :: kernel
integer(c_size_t)                                  :: cnum
character(9),target                                :: kernelname
character(10, KIND=c_char),target                  :: ckernelname

integer(kind=irg)                                  :: i, j, ii, iii, jj, pp, kk, ll ! loop variables
integer(kind=irg)                                  :: FZcnt, pgnum, io_int(3), ncubochoric, istat, itmpexpt = 43, cratio, &
                                                      fratio, cratioE, fratioE
integer(kind=irg)                                  :: Ne, Nd, L, totnumexpt, imght, imgwd, nnk, recordsize, correctsize, curdict,&
                                                      recordsize_correct
integer(kind=8)                                    :: size_in_bytes_dict, size_in_bytes_expt
real(kind=sgl)                                     :: dmin, voltage, projweight, qu(4), mi, ma, io_real(1), ratio, ratioE
real(kind=sgl),allocatable                         :: FZarray(:,:)
logical                                            :: verbose, f_exists
character                                          :: TAB
type(FZpointd),pointer                             :: FZlist, FZtmp
real(kind=sgl),pointer                             :: dict(:), T0dict(:)
real(kind=sgl),allocatable,TARGET                  :: dict1(:), dict2(:)
real(kind=sgl),allocatable,TARGET                  :: expt(:), dicttranspose(:), results(:), resultarray(:), eulerarray(:,:), &
                                                      resultmain(:,:), resulttmp(:,:)
real(kind=sgl),allocatable                         :: mask(:,:),masklin(:)
real(kind=sgl),allocatable                         :: imageexpt(:), tmpimageexpt(:), imagedict(:)
real(kind=sgl),allocatable                         :: meandict(:), meanexpt(:), ECPattern(:,:)
integer(kind=irg),allocatable                      :: indexlist(:), indexarray(:), indexmain(:,:), indextmp(:,:),  &
                                                      ppend(:), ppendE(:)
real(kind=sgl),allocatable                         :: ECPpattern(:,:), ECPpatternintd(:,:),ECP1D(:)
integer(kind=irg),allocatable                      :: ECPpatterninteger(:,:), ECPpatternad(:,:)
integer(c_size_t),target                           :: slength
integer(c_int)                                     :: numd, nump

complex(kind=dbl)                                  :: D

character(fnlen)                                   :: info ! info about the GPU
integer(kind=irg)                                  :: irec, iunit, num

integer,parameter                                  :: iunitexpt = 42

character(fnlen)                                   :: str1,str2,str3,str4,str5,str6,str7,str8,str9,str10, clname, ename, sourcefile
real(kind=sgl)                                     :: euler(3)
integer(kind=irg)                                  :: index, TID
integer(kind=irg)                                  :: ipar(10), hdferr

character(11)                                      :: dstr
character(15)                                      :: tstrb
character(15)                                      :: tstre
real(kind=sgl)                                     :: tstart

interface
     recursive subroutine CalcECPatternSingle(ecpnl, qu, anglewf, master, kij, klist, ECPattern)

       use error
       use typedefs
       use NameListTypedefs
       use ECPmod
       use quaternions
       use Lambert

       IMPLICIT NONE

       type(ECPIndexingNameListType),INTENT(IN)        :: ecpnl
       real(kind=sgl),INTENT(IN)                       :: qu(4)
       real(kind=sgl),INTENT(IN)                       :: anglewf(nint((ecpnl%thetac) + abs(ecpnl%sampletilt)) + 1)
       type(ECPMasterType),pointer                     :: master
       integer(kind=irg),INTENT(IN)                    :: kij(2,ecpnl%npix**2)
       real(kind=sgl),INTENT(IN)                       :: klist(3,ecpnl%npix**2)
       real(kind=sgl),INTENT(OUT)                      :: ECPattern(1:ecpnl%npix,1:ecpnl%npix)

     end subroutine CalcECPatternSingle
end interface

call timestamp(datestring=dstr, timestring=tstrb)
call cpu_time(tstart)

!=====================================================
! INITIALIZATION OF VARIOUS PARAMETERS
!=====================================================
TAB = CHAR(9)
iunit = 20
verbose =  .FALSE. ! .TRUE.
Ne = ecpnl%numexptsingle
Nd = ecpnl%numdictsingle
totnumexpt = ecpnl%totnumexpt
imght = ecpnl%npix
imgwd = ecpnl%npix
L = imght*imgwd
nnk = ecpnl%nnk
dmin = ecpnl%dmin
voltage = ecpnl%EkeV
ncubochoric = ecpnl%ncubochoric
recordsize = L*4
source_l = source_length

! nullify the dict  and T0dict pointers
nullify(dict,T0dict)

!D = cmplx(0.000001,-0.00000185)

if (mod(L,16) .ne. 0) then
    correctsize = 16*ceiling(float(L)/16.0)
else
    correctsize = L
end if

size_in_bytes_dict = Nd*correctsize*sizeof(dict(1))
size_in_bytes_expt = Ne*correctsize*sizeof(expt(1))
recordsize_correct = correctsize*4

!=====================================================
! EXTRACT POINT GROUP NUMBER FROM CRYSTAL STRUCTURE FILE
!=====================================================
pgnum = GetPointGroup(ecpnl%MCxtalname,.FALSE.)

!=====================================================
! SAMPLING OF RODRIGUES FUNDAMENTAL ZONE
!=====================================================
nullify(FZlist)
FZcnt = 0
io_int(1) = pgnum
io_int(2) = ncubochoric
call WriteValue('Point group number and number of cubochoric sampling points : ',io_int,2,"(I4,',',I5)")

call sampleRFZ(ncubochoric, pgnum, 0, FZcnt, FZlist)

! allocate and fill FZarray for OpenMP parallelization
allocate(FZarray(4,FZcnt),stat=istat)
FZarray = 0.0

FZtmp => FZlist

do i = 1,FZcnt
    FZarray(1:4,i) = FZtmp%rod(1:4)
    FZtmp => FZtmp%next
end do

io_int(1) = FZcnt
call WriteValue(' Number of dictionary patterns to consider : ', io_int, 1, "(I8)")

!=========================================
! ALLOCATION AND INITIALIZATION OF ARRAYS
!=========================================

allocate(expt(Ne*correctsize),stat=istat)
if (istat .ne. 0) stop 'Could not allocate array for experimental patterns'
expt = 0.0

! allocate the two dict arrays dict1 and dict2 and point dict to dict1
allocate(dict1(Nd*correctsize),dict2(Nd*correctsize),stat=istat)
if (istat .ne. 0) stop 'Could not allocate dict1 and dict2 arrays for dictionary patterns'
dict1 = 0.0
dict2 = 0.0
dict => dict1
curdict = 1

allocate(dicttranspose(Nd*correctsize),stat=istat)
if (istat .ne. 0) stop 'Could not allocate array for dictionary patterns'
dicttranspose = 0.0

allocate(results(Ne*Nd),stat=istat)
if (istat .ne. 0) stop 'Could not allocate array for results of dot product'
results = 0.0

allocate(imageexpt(L),tmpimageexpt(correctsize),imagedict(correctsize),stat=istat)
if (istat .ne. 0) stop 'Could not allocate array for reading experimental image patterns'
imageexpt = 0.0
tmpimageexpt = 0.0
imagedict = 0.0

allocate(meandict(correctsize),meanexpt(correctsize),mask(imght,imgwd),masklin(L),stat=istat)
if (istat .ne. 0) stop 'Could not allocate array for mean dictionary and experimental patterns'
meandict = 0.0
meanexpt = 0.0
mask = 1.0
masklin = 0.0

allocate(ECPattern(1:ecpnl%npix,1:ecpnl%npix))
if (istat .ne. 0) stop 'Could not allocate array for channeling pattern'
ECPattern = 0.0

allocate(resultarray(Nd),stat=istat)
if (istat .ne. 0) stop 'Could not allocate result arrays'
resultarray = 0.0

allocate(indexarray(1:Nd),stat=istat)
if (istat .ne. 0) stop 'Could not allocate index arrays'
indexarray = 0

allocate(indexlist(1:Nd*(ceiling(float(FZcnt)/float(Nd)))),stat=istat)
if (istat .ne. 0) stop 'Could not allocate indexlist arrays'
indexlist = (/ (i,i = 1,Nd*ceiling(float(FZcnt)/float(Nd))) /)

allocate(resultmain(nnk,Ne*ceiling(float(totnumexpt)/float(Ne))),stat=istat)
if (istat .ne. 0) stop 'Could not allocate main result array'
resultmain = 0.0

allocate(indexmain(nnk,Ne*ceiling(float(totnumexpt)/float(Ne))),stat=istat)
if (istat .ne. 0) stop 'Could not allocate main index array'
indexmain = 0

allocate(resulttmp(2*nnk,Ne*ceiling(float(totnumexpt)/float(Ne))),stat=istat)
if (istat .ne. 0) stop 'Could not allocate temporary result array'
resulttmp = 0.0

allocate(indextmp(2*nnk,Ne*ceiling(float(totnumexpt)/float(Ne))),stat=istat)
if (istat .ne. 0) stop 'Could not allocate temporary index array'
indextmp = 0

allocate(eulerarray(1:3,Nd*ceiling(float(FZcnt)/float(Nd))),stat=istat)
if (istat .ne. 0) stop 'Could not allocate euler array'
eulerarray = 0.0

allocate(ECPpatternintd(1:ecpnl%npix,1:ecpnl%npix),&
ECP1D(ecpnl%npix*ecpnl%npix),&
ECPpattern(1:ecpnl%npix,1:ecpnl%npix),&
ECPpatterninteger(1:ecpnl%npix,1:ecpnl%npix),&
ECPpatternad(1:ecpnl%npix,1:ecpnl%npix),stat=istat)

ECPpatternintd = 0.0
ECPpatterninteger = 0
ECPpatternad = 0

!==========================
! INITIALIZATION OF DEVICE
!==========================
call CLinit_PDCCQ(platform, nump, ecpnl%platid, device, numd, ecpnl%devid, info, context, command_queue)

! read the source file
sourcefile = 'DictIndx.cl'
call CLread_source_file(sourcefile, csource, slength)

! allocate device memory
cl_expt = clCreateBuffer(context, CL_MEM_READ_WRITE, size_in_bytes_expt, C_NULL_PTR, ierr)
if(ierr /= CL_SUCCESS) stop 'Error: cannot allocate device memory for experimental data.'

cl_dict = clCreateBuffer(context, CL_MEM_READ_WRITE, size_in_bytes_dict, C_NULL_PTR, ierr)
if(ierr /= CL_SUCCESS) stop 'Error: cannot allocate device memory for dictionary data.'

!================================
! the following lines were originally in the InnerProdGPU routine, but there is no need
! to execute them each time that routine is called so we move them here...
!================================
! create the program
pcnt = 1
psource = C_LOC(csource)
!prog = clCreateProgramWithSource(context, pcnt, C_LOC(psource), C_LOC(source_l), ierr)
prog = clCreateProgramWithSource(context, pcnt, C_LOC(psource), C_LOC(slength), ierr)
call CLerror_check('InnerProdGPU:clCreateProgramWithSource', ierr)

! build the program
ierr = clBuildProgram(prog, numd, C_LOC(device), C_NULL_PTR, C_NULL_FUNPTR, C_NULL_PTR)

! get the compilation log
ierr2 = clGetProgramBuildInfo(prog, device(ecpnl%devid), CL_PROGRAM_BUILD_LOG, sizeof(source), C_LOC(source), cnum)
! if(cnum > 1) call Message(trim(source(1:cnum))//'test',frm='(A)')
call CLerror_check('InnerProdGPU:clBuildProgram', ierr)
call CLerror_check('InnerProdGPU:clGetProgramBuildInfo', ierr2)

! finally get the kernel and release the program
kernelname = 'InnerProd'
ckernelname = kernelname
ckernelname(10:10) = C_NULL_CHAR
kernel = clCreateKernel(prog, C_LOC(ckernelname), ierr)
call CLerror_check('InnerProdGPU:clCreateKernel', ierr)

ierr = clReleaseProgram(prog)
call CLerror_check('InnerProdGPU:clReleaseProgram', ierr)

! the remainder is done in the InnerProdGPU routine
!=========================================

!====================================================================================
! I/O FOR EXPERIMENTAL DATA SET AND APPLICATION OF MASK IF ANY
!====================================================================================

call Message(' -> opened experimental file for I/O', frm = "(A)" )

ename = trim(EMsoft_getEMdatapathname())//trim(ecpnl%exptfile)
ename = EMsoft_toNativePath(ename)
open(unit=iunitexpt,file=trim(ename),&
    status='old',form='unformatted',access='direct',recl=recordsize,iostat=ierr)

if (ecpnl%maskpattern.eq.'y') then
  do ii = 1,imght
      do jj = 1,imgwd
          if((ii-imght/2)**2 + (jj-imgwd/2)**2 .ge. ecpnl%maskradius**2) then
              mask(ii,jj) = 0.0
          end if
      end do
  end do
end if

do ii = 1,imght
    do jj = 1,imgwd
        masklin((ii-1)*imgwd+jj) = mask(ii,jj)
    end do
end do

!=========================================
! determine loop variables to avoid having to duplicate large sections of mostly identical code
!=========================================
ratio = float(FZcnt)/float(Nd)
cratio = ceiling(ratio)
fratio = floor(ratio)

ratioE = float(totnumexpt)/float(Ne)
cratioE = ceiling(ratioE)
fratioE = floor(ratioE)

allocate(ppend(cratio),ppendE(cratioE))
ppend = (/ (Nd, i=1,cratio) /)
if (fratio.lt.cratio) then
  ppend(cratio) = MODULO(FZcnt,Nd)
end if

ppendE = (/ (Ne, i=1,cratioE) /)
if (fratioE.lt.cratioE) then
  ppendE(cratioE) = MODULO(totnumexpt,Ne)
end if

!=========================================
! PREPARE THE EXPERIMENTAL PATTERNS
!=========================================
! in this section, we read all the experimental patterns
! and apply adaptive histogram equalization, masking, and
! whatever other filters we like to apply; then we store
! those patterns in a temporary file from which they will
! be read when needed.

! first, make sure that this file does not already exist
f_exists = .FALSE.
ename = trim(EMsoft_getEMdatapathname())//trim(ecpnl%tmpfile)
ename = EMsoft_toNativePath(ename)
inquire(file=trim(ename), exist=f_exists)

if (f_exists) then
  open(unit=itmpexpt,file=trim(ename),&
      status='unknown',form='unformatted',access='direct',recl=recordsize_correct,iostat=ierr)
  close(unit=itmpexpt,status='delete')
end if

! open the temporary file
open(unit=itmpexpt,file=trim(ename),&
    status='unknown',form='unformatted',access='direct',recl=recordsize_correct,iostat=ierr)

prepexperimentalloop: do jj = 1,totnumexpt
    tmpimageexpt = 0.0
    read(iunitexpt,rec=jj) imageexpt

! convert imageexpt to 2D ECPattern array
    do kk=1,ecpnl%npix
      ECPattern(kk,1:ecpnl%npix) = imageexpt((kk-1)*ecpnl%npix+1:kk*ecpnl%npix)
    end do

! adaptive histogram equalization
    ma = maxval(imageexpt)
    mi = minval(imageexpt)

    ECPpatternintd = ((ECPattern - mi)/ (ma-mi))
    ECPpatterninteger = nint(ECPpatternintd*255.0)
    ECPpatternad =  adhisteq(ecpnl%nregions,ecpnl%npix,ecpnl%npix,ECPpatterninteger)
    ECPattern = float(ECPpatternad)

! convert back to 1D vector
    do kk=1,ecpnl%npix
      imageexpt((kk-1)*ecpnl%npix+1:kk*ecpnl%npix) = ECPattern(kk,1:ecpnl%npix)
    end do

    imageexpt(1:L) = imageexpt(1:L)*masklin(1:L)
    tmpimageexpt(1:L) = imageexpt(1:L)
!   projweight = DOT_PRODUCT(imageexpt,meanexpt)
!   tmpimageexpt(1:L) = imageexpt - projweight*meanexpt(1:L)
    tmpimageexpt = tmpimageexpt/vecnorm(tmpimageexpt)

! and write this pattern into the temporary file
    write(itmpexpt,rec=jj) tmpimageexpt
end do prepexperimentalloop

close(unit=iunitexpt,status='keep')
! we keep the temporary file open since we will be reading from it...

!=========================================
!=========================================
!=========================================
! MAIN COMPUTATION LOOP
! this is a complicated loop since we want to have the GPU computations
! to occur at the same time as the next batch of dictionary patterns is computed.
! We can do this if we use two dict arrays in an alternating fashion, and we
! flip pointers back and forth so that the GPU works on one dict array while
! the threads compute the other one.  So we make dict a pointer to the targets
! dict1 and dict2 and simply alternate at the start of the main loop. The other
! pointer, T0dict (dict for thread 0) points to the other array.  We also put
! OMP barrier statements in to ensure that the threads wait for each other at
! the end of each cycle.  Finally, we must remember to add one more GPU cycle
! at the end of the dictionaryloop to make sure that we process all the dict patterns.
!=========================================
!=========================================
!=========================================

call timestamp()

! set the correct number of threads
call OMP_SET_NUM_THREADS(ecpnl%nthreads)
io_int(1) = ecpnl%nthreads
call WriteValue(' -> Number of threads set to ',io_int,1,"(I3)")

! start the main dictionary loop
dictionaryloop: do ii = 1,cratio+1      ! +1 is needed to make sure that the final GPU run is carried out
    results = 0.0
! if ii is odd, then we use dict1 for the dictionary computation, and dict2 for the GPU
! (assuming ii>1); when ii is even we switch the two pointers
    if (mod(ii,2).eq.1) then
      dict => dict1
      dict1 = 0.0
      T0dict => dict2   ! these are the patterns to be sent to the GPU
      curdict = 2
      if (verbose.eqv..TRUE.) call WriteValue('','dict => dict1; T0dict => dict2')
    else
      dict => dict2
      dict2 = 0.0
      T0dict => dict1   ! these are the patterns to be sent to the GPU
      curdict = 1
      if (verbose.eqv..TRUE.) call WriteValue('','dict => dict2; T0dict => dict1')
    end if

    if (verbose.eqv..TRUE.) then
      io_int(1) = ii
      call WriteValue('Dictionaryloop index = ',io_int,1)
    end if

!$OMP PARALLEL DEFAULT(PRIVATE) &
!$OMP& SHARED(FZarray,ecpnl,anglewf,master,kij,klist,ii,meandict,Nd,imght,imgwd,correctsize,D,eulerarray,masklin) &
!$OMP& SHARED(dict1,dict2,T0dict,dict,curdict,expt,dicttranspose,command_queue,cl_dict,size_in_bytes_dict,ierr,Ne) &
!$OMP& SHARED(itmpexpt,totnumexpt,tmpimageexpt,cl_expt,size_in_bytes_expt,results,source,slength,platform,device) &
!$OMP& SHARED(context,io_real,resultarray,indexarray,resulttmp,indextmp,resultmain,indexmain,nnk,indexlist) &
!$OMP& SHARED(cratio,fratio,ppend,verbose,cratioE,ppendE,nump,numd,csource)

    TID = OMP_GET_THREAD_NUM()

! the master thread should be the one working on the GPU computation
!$OMP MASTER
    if (ii.gt.1) then
      iii = ii-1        ! the index ii is already one ahead, since the GPU thread lags one cycle behind the others...
      if (verbose.eqv..TRUE.) then
        if (associated(T0dict,dict1)) then
          write(*,"('   GPU thread is working on dict1')")
        else
          write(*,"('   GPU thread is working on dict2')")
        end if
      end if
!--CHECK THIS !!!--------------------------------
! Saransh, we do not really need to transpose this, since the cl routine then transposes again...

      dicttranspose = 0.0

      do kk = 1,correctsize
        do ll = 1,Nd
            dicttranspose((kk-1)*Nd+ll) = T0dict((ll-1)*correctsize+kk)
        end do
      end do
!------------------------------------------------

      ierr = clEnqueueWriteBuffer(command_queue, cl_dict, CL_TRUE, 0_8, size_in_bytes_dict, C_LOC(dicttranspose(1)), &
                                  0, C_NULL_PTR, C_NULL_PTR)
      if(ierr /= CL_SUCCESS) call FatalError('clEnqueueWriteBuffer:','cannot write to dicttranspose buffer.')

!------------------------------------------------
! this loop is now faster since we have stored the modified experimental patterns in a temporary file
      experimentalloop: do jj = 1,cratioE

        expt = 0.0
        tmpimageexpt = 0.0

        do pp = 1,ppendE(jj)
          read(itmpexpt,rec=(jj-1)*Ne+pp) tmpimageexpt
          expt((pp-1)*correctsize+1:pp*correctsize) = tmpimageexpt
        end do

        ierr = clEnqueueWriteBuffer(command_queue, cl_expt, CL_TRUE, 0_8, size_in_bytes_expt, C_LOC(expt(1)), &
                                    0, C_NULL_PTR, C_NULL_PTR)
        if(ierr /= CL_SUCCESS) call FatalError('clEnqueueWriteBuffer','cannot write to expt buffer.')

        call InnerProdGPU(cl_expt,cl_dict,Ne,Nd,correctsize,results,numd,ecpnl%devid,kernel,context,command_queue)

        do pp = 1,ppendE(jj)

            resultarray(1:Nd) = results((pp-1)*Nd+1:pp*Nd)
            indexarray(1:Nd) = indexlist((iii-1)*Nd+1:iii*Nd)

            call SSORT(resultarray,indexarray,Nd,-2)
            resulttmp(nnk+1:2*nnk,(jj-1)*Ne+pp) = resultarray(1:nnk)
            indextmp(nnk+1:2*nnk,(jj-1)*Ne+pp) = indexarray(1:nnk)

            call SSORT(resulttmp(:,(jj-1)*Ne+pp),indextmp(:,(jj-1)*Ne+pp),2*nnk,-2)

            resultmain(1:nnk,(jj-1)*Ne+pp) = resulttmp(1:nnk,(jj-1)*Ne+pp)

            indexmain(1:nnk,(jj-1)*Ne+pp) = indextmp(1:nnk,(jj-1)*Ne+pp)

        end do
        io_real(1) = maxval(results)
        call WriteValue('Max(results) = ',io_real,1)

      end do experimentalloop

      if (mod(iii,25) .eq. 0) then
        io_int(1:2) = (/iii,cratio/)
        call WriteValue('',io_int,2,"(' -> Completed cycle ',I5,' out of ',I5)")
      end if
    else
       if (verbose.eqv..TRUE.) call WriteValue('','        GPU thread is idling')
    end if  ! ii.gt.1
!$OMP END MASTER

! here we carry out the dictionary pattern computation, unless we are in the ii=cratio+1 step
    if (ii.lt.cratio+1) then
     if (verbose.eqv..TRUE.) then
       if (associated(dict,dict1)) then
         write(*,"('    Thread ',I2,' is working on dict1')") TID
       else
         write(*,"('    Thread ',I2,' is working on dict2')") TID
       end if
     end if

!$OMP DO SCHEDULE(DYNAMIC)
        do pp = 1, ppend(ii)
            qu = ro2qu(FZarray(:,(ii-1)*Nd+pp))
            call CalcECPatternSingle(ecpnl, qu, anglewf, master, kij, klist, ECPattern)

            !call BarrelDistortion(D,ECPattern,imght,imgwd)

! adaptive histogram equalization
            ma = maxval(ECPattern)
            mi = minval(ECPattern)

            ECPpatternintd = ((ECPattern - mi)/ (ma-mi))
            ECPpatterninteger = nint(ECPpatternintd*255.0)
            ECPpatternad =  adhisteq(ecpnl%nregions,ecpnl%npix,ecpnl%npix,ECPpatterninteger)
            ECPattern = float(ECPpatternad)

            do kk = 1, imght
                do ll = 1, imgwd
                    imagedict((kk-1)*imgwd+ll) = ECPattern(ll,kk)
                end do
            end do

            imagedict(1:L) = imagedict(1:L) * masklin(1:L)

! normalize pattern vector
            dict((pp-1)*correctsize+1:pp*correctsize) = imagedict(1:correctsize)/vecnorm(imagedict(1:correctsize))
! dot product with mean dictionary pattern (not used at the moment)
!           projweight = DOT_PRODUCT(meandict,dict((pp-1)*correctsize+1:pp*correctsize))
! project out the mean dictionary pattern
!           dict((pp-1)*correctsize+1:pp*correctsize) = dict((pp-1)*correctsize+1:pp*correctsize) - projweight*meandict
! normalize the resulting pattern
!           dict((pp-1)*correctsize+1:pp*correctsize) = dict((pp-1)*correctsize+1:pp*correctsize)&
!           /vecnorm(dict((pp-1)*correctsize+1:pp*correctsize))

            eulerarray(1:3,(ii-1)*Nd+pp) = 180.0/cPi*ro2eu(FZarray(1:4,(ii-1)*Nd+pp))
        end do
!$OMP END DO
        if (verbose.eqv..TRUE.) then
          io_int(1) = TID
          call WriteValue('',io_int,1,"('       Thread ',I2,' is done')")
        end if
     else
        if (verbose.eqv..TRUE.) then
          io_int(1) = TID
          call WriteValue('',io_int,1,"('       Thread ',I2,' idling')")
        end if
     end if
! and we end the parallel section here (all threads will synchronize).
!$OMP END PARALLEL

end do dictionaryloop

call timestamp()

! remove the temporary file
close(unit=itmpexpt,status='delete')

! release the OpenCL kernel
ierr = clReleaseKernel(kernel)
call CLerror_check('InnerProdGPU:clReleaseKernel', ierr)

! ===================
! MAIN OUTPUT SECTION
! ===================

! fill the ipar array with integer parameters that are needed to write the h5ebsd file
! (anything other than what is already in the ebsdnl structure)
ipar = 0
ipar(1) = nnk
ipar(2) = Ne*ceiling(float(totnumexpt)/float(Ne))
ipar(3) = totnumexpt
ipar(4) = Nd*ceiling(float(FZcnt)/float(Nd))
ipar(5) = FZcnt
ipar(6) = pgnum

! Initialize FORTRAN interface.
call h5open_EMsoft(hdferr)

if (ecpnl%datafile.ne.'undefined') then
  call h5ecp_writeFile(ecpnl, dstr, tstrb, ipar, resultmain, indexmain, eulerarray, &
                       progname, nmldeffile)
  call Message('Data stored in h5ebsd file : '//trim(ecpnl%datafile))
end if

if (ecpnl%ctffile.ne.'undefined') then
    call ctfecp_writeFile(ecpnl,ipar,indexmain,eulerarray,resultmain)
    call Message('Data stored in ctf file : '//trim(ecpnl%ctffile))
end if

end subroutine MasterSubroutine

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

!--------------------------------------------------------------------------
!
! SUBROUTINE:CalcECPatternSingle
!
!> @author Saransh Singh, Carnegie Mellon University
!
!> @brief Calculate a single EC pattern for a given euler angle
!
!> @param ecpnl namelist file for ebsd
!> @param qu quaternion for the pattern
!> @param acc accumulator array from MC simulation
!> @param master master pattern
!> @param ECPattern output array
!
!> @date 05/07/15  SS 1.0 original
!--------------------------------------------------------------------------
recursive subroutine CalcECPatternSingle(ecpnl, qu, anglewf, master, kij, klist, ECPattern)

use error
use typedefs
use NameListTypedefs
use ECPmod
use quaternions
use Lambert

IMPLICIT NONE

type(ECPIndexingNameListType),INTENT(IN)        :: ecpnl
real(kind=sgl),INTENT(IN)                       :: qu(4)
real(kind=sgl),INTENT(IN)                       :: anglewf(nint((ecpnl%thetac) + abs(ecpnl%sampletilt)) + 1)
type(ECPMasterType),pointer                     :: master
integer(kind=irg),INTENT(IN)                    :: kij(2,ecpnl%npix**2)
real(kind=sgl),INTENT(IN)                       :: klist(3,ecpnl%npix**2)
real(kind=sgl),INTENT(OUT)                      :: ECPattern(1:ecpnl%npix,1:ecpnl%npix)

real(kind=dbl),parameter                        :: Rtod = 57.2957795131D0
real(kind=dbl),parameter                        :: dtoR = 0.01745329251D0
integer(kind=irg)                               :: numk, idir, isig, isigp, nsig, istat
real(kind=sgl)                                  :: dc(3), dp, MCangle, scl, ixy(2)
real(kind=sgl)                                  :: wf, dx, dy, dxm, dym
integer(kind=irg)                               :: nix, niy, nixp, niyp, ipx, ipy

numk = ecpnl%npix**2
nsig = nint((ecpnl%thetac) + abs(ecpnl%sampletilt)) + 1
scl = dble(ecpnl%npx)

do idir = 1,numk

! do the active coordinate transformation for this euler angle
    dc = klist(1:3,idir)
    dp = DOT_PRODUCT(dc(1:3),(/dsin(ecpnl%sampletilt*dtoR),0.D0,dcos(ecpnl%sampletilt*dtoR)/))

    MCangle = acos(dp)*Rtod
! find index closest to the list of MC runs we already have and interpolate the weight factor
    isig = int(MCangle) + 1
    if (isig .gt. nsig) isig = nsig

    isigp = isig + 1
    if (isigp .gt. nsig) isigp = nsig

    dx = MCangle - int(MCangle)
    dxm =  1.0 - dx

    wf = anglewf(isig) * dxm + anglewf(isigp) * dx

    dc = quat_LP(qu,dc)
    dc = dc/sqrt(sum(dc*dc))

! convert these direction cosines to coordinates in the Rosca-Lambert projection
    call LambertgetInterpolation(dc, scl, ecpnl%npx, ecpnl%npy, nix, niy, nixp, niyp, dx, dy, dxm, dym)

! interpolate the intensity
    ipx = kij(1,idir)
    ipy = kij(2,idir)

! including the detector model with some sample tilt
    if (dc(3) .gt. 0.0) then

        ECPattern(ipx,ipy) = wf * (master%mLPNH(nix,niy) * dxm * dym + &
                          master%mLPNH(nixp,niy) * dx * dym + &
                          master%mLPNH(nix,niyp) * dxm * dy + &
                          master%mLPNH(nixp,niyp) * dx * dy)

    else

        ECPattern(ipx,ipy) =  wf * (master%mLPSH(nix,niy) * dxm * dym + &
                          master%mLPSH(nixp,niy) * dx * dym + &
                          master%mLPSH(nix,niyp) * dxm * dy + &
                          master%mLPSH(nixp,niyp) * dx * dy)

    end if

end do

end subroutine CalcECPatternSingle


!        Generated by TAPENADE     (INRIA, Ecuador team)
!  tapenade 3.x
!
!  Differentiation of li in reverse (adjoint) mode (with options noISIZE i8):
!   gradient     of useful results: *temp *propunit *tsal li
!   with respect to varying inputs: *temp *propunit *tsal
!   Plus diff mem management of: temp:in propunit:in tsal:in pres:in
!>    @brief average thermal conductivities on cell faces in x direction
!>    @param[in] i grid indices
!>    @param[in] j grid indices
!>    @param[in] k grid indices
!>    @param[in] ismpl local sample index
!>    @return x thermal conductivity (J/mK)
SUBROUTINE LI_AD(i, j, k, ismpl, li_adv)
  use arrays

  USE ARRAYS_AD

  USE MOD_GENRL
  USE MOD_TEMP
  IMPLICIT NONE
  double precision :: li_adv
  INTEGER :: ismpl
  INTEGER :: i, j, k
  EXTERNAL LX
  EXTERNAL LX_AD
  DOUBLE PRECISION :: f1, f2, prod, summ, LX
  DOUBLE PRECISION :: f1_ad, f2_ad, prod_ad, summ_ad
  INTEGER :: arg1
  DOUBLE PRECISION :: temporary_ad
  DOUBLE PRECISION :: li
  IF (i0 .GT. 1 .AND. i .LT. i0) THEN
    f1 = LX(i, j, k, ismpl)
    arg1 = i + 1
    f2 = LX(arg1, j, k, ismpl)
    prod = f1*f2
    summ = f1*delx(i+1) + f2*delx(i)
    IF (summ .GT. 0.d0) THEN
      temporary_ad = 2.d0*li_adv/summ
      prod_ad = temporary_ad
      summ_ad = -(prod*temporary_ad/summ)
    ELSE
      prod_ad = 0.D0
      summ_ad = 0.D0
    END IF
    f1_ad = delx(i+1)*summ_ad + f2*prod_ad
    f2_ad = delx(i)*summ_ad + f1*prod_ad
    CALL LX_AD(arg1, j, k, ismpl, f2_ad)
    CALL LX_AD(i, j, k, ismpl, f1_ad)
  END IF
END SUBROUTINE LI_AD


C
C $Id: curvp2dp.f,v 1.3 2008-07-27 03:10:10 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
C NOTE: If you make any changes to this software, please remember to
C make the same changes to the corresponding single precision routine.
C
      FUNCTION CURVP2DP(T,N,X,Y,P,YP,SIGMA)
      DOUBLE PRECISION CURVP2DP
      DOUBLE PRECISION TP
      DOUBLE PRECISION SIGMAP
      DOUBLE PRECISION DEL1
      DOUBLE PRECISION DEL2
      DOUBLE PRECISION DELS
      DOUBLE PRECISION SUM
      DOUBLE PRECISION SIGDEL
      DOUBLE PRECISION SS
      DOUBLE PRECISION DUMMY
      DOUBLE PRECISION S1
      DOUBLE PRECISION S2
c
      INTEGER N
      DOUBLE PRECISION T,X(N),Y(N),P,YP(N),SIGMA
c
c                                 coded by alan kaylor cline
c                           from fitpack -- january 26, 1987
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this function interpolates a curve at a given point using
c a periodic spline under tension. the subroutine curvp1
c should be called earlier to determine certain necessary
c parameters.
c
c on input--
c
c   t contains a real value to be mapped onto the interpo-
c   lating curve.
c
c   n contains the number of points which were specified to
c   determine the curve.
c
c   x and y are arrays containing the abscissae and
c   ordinates, respectively, of the specified points.
c
c   p contains the period.
c
c   yp is an array of second derivative values of the curve
c   at the nodes.
c
c and
c
c   sigma contains the tension factor (its sign is ignored).
c
c the parameters n, x, y, p, yp, and sigma should be input
c unaltered from the output of curvp1.
c
c on output--
c
c   curvp2dp contains the interpolated value.
c
c none of the input parameters are altered.
c
c this function references package modules intrvpdp and
c snhcshdp.
c
c-----------------------------------------------------------
c
c determine interval
c
      IM1 = INTRVPDP(T,X,N,P,TP)
      I = IM1 + 1
c
c denormalize tension factor
c
      SIGMAP = ABS(SIGMA)*DBLE(N)/P
c
c set up and perform interpolation
c
      DEL1 = TP - X(IM1)
      IF (IM1.EQ.N) GO TO 1
      DEL2 = X(I) - TP
      DELS = X(I) - X(IM1)
      GO TO 2
    1 I = 1
      DEL2 = X(1) + P - TP
      DELS = P - (X(N)-X(1))
    2 SUM = (Y(I)*DEL1+Y(IM1)*DEL2)/DELS
      IF (SIGMAP.NE.0.D0) GO TO 3
      CURVP2DP = SUM - DEL1*DEL2* (YP(I)* (DEL1+DELS)+
     +         YP(IM1)* (DEL2+DELS))/ (6.D0*DELS)
      RETURN
    3 SIGDEL = SIGMAP*DELS
      CALL SNHCSHDP(SS,DUMMY,SIGDEL,-1)
      CALL SNHCSHDP(S1,DUMMY,SIGMAP*DEL1,-1)
      CALL SNHCSHDP(S2,DUMMY,SIGMAP*DEL2,-1)
      CURVP2DP = SUM + (YP(I)*DEL1* (S1-SS)+YP(IM1)*DEL2* (S2-SS))/
     +         (SIGDEL*SIGMAP* (1.D0+SS))
      RETURN
      END


!-----------------------------------------------------------------------
!
      module mfft1
!
! Fortran90 wrappers to 1d OpenMP PIC library libmfft1.f
! mfft1_init calculates tables needed by 1d FFTs
!            calls WFFT1RINIT
! mfft1r wrapper function for in place scalar 1d real/complex FFT
!        calls FFT1RXX
! mfft1rn wrapper function for in place vector 1d real/complex FFT
!         calls FFT1R2X or FFT1R3X
! mfft1cr wrapper function for scalar 1d complex to real FFT
!         calls FFT1RXX
! mfft1crn wrapper function for vector 1d complex to real FFT
!          calls FFT1R2X or FFT1R3X
! written by viktor k. decyk, ucla
! copyright 2016, regents of the university of california
! update: january 9, 2017
!
      use libmfft1_h
      implicit none
!
! t = scratch array for mfft1rn
      complex, dimension(:), allocatable :: t
      integer :: szt = 0
      save
!
      private :: t, szt
!
      contains
!
!-----------------------------------------------------------------------
      subroutine mfft1_init(mixup,sct,indx)
! calculates tables needed by 1d FFTs
      implicit none
      integer, intent(in) :: indx
      integer, dimension(:), intent(inout) :: mixup
      complex, dimension(:), intent(inout) :: sct
! local data
      integer :: nxhd
! extract dimensions
      nxhd = size(mixup,1)
! call low level procedure
      call WFFT1RINIT(mixup,sct,indx,nxhd)
      end subroutine
!
!-----------------------------------------------------------------------
      subroutine mfft1r(f,isign,mixup,sct,tfft,indx)
! wrapper function for scalar 1d real/complex FFT
      implicit none
      integer, intent(in) :: isign, indx
      real, dimension(:), intent(inout) :: f
      integer, dimension(:), intent(in) :: mixup
      complex, dimension(:), intent(in) :: sct
      real, intent(inout) :: tfft
! local data
      integer :: nxd, nxhd
      integer, dimension(4) :: itime
      double precision :: dtime
! extract dimensions
      nxd = size(f,1)
      nxhd = size(mixup,1)
! check if required size of buffer has increased
      if (szt < nxhd) then
         if (szt /= 0) deallocate(t)
! allocate new buffers
         allocate(t(nxhd))
         szt = nxhd
      endif
! initialize timer
      call dtimer(dtime,itime,-1)
! call low level procedure
      call FFT1RXX(f,t,isign,mixup,sct,indx,nxd,nxhd)
! record time
      call dtimer(dtime,itime,1)
      tfft = tfft + real(dtime)
      end subroutine
!
!-----------------------------------------------------------------------
      subroutine mfft1rn(f,isign,mixup,sct,tfft,indx)
! wrapper function for n component vector 1d real/complex FFT
      implicit none
      integer, intent(in) :: isign, indx
      real, dimension(:,:), intent(inout) :: f
      integer, dimension(:), intent(in) :: mixup
      complex, dimension(:), intent(in) :: sct
      real, intent(inout) :: tfft
! local data
      integer :: ndim, nxd, nxhd
      integer, dimension(4) :: itime
      double precision :: dtime
! extract dimensions
      ndim = size(f,1); nxd = size(f,2)
      nxhd = size(mixup,1)
! check if required size of buffer has increased
      if (szt < ndim*nxhd) then
         if (szt /= 0) deallocate(t)
! allocate new buffers
         allocate(t(ndim*nxhd))
         szt = ndim*nxhd
      endif
! initialize timer
      call dtimer(dtime,itime,-1)
! call low level procedure
      select case(ndim)
      case (2)
         call FFT1R2X(f,t,isign,mixup,sct,indx,nxd,nxhd)
      case (3)
         call FFT1R3X(f,t,isign,mixup,sct,indx,nxd,nxhd)
      end select
! record time
      call dtimer(dtime,itime,1)
      tfft = tfft + real(dtime)
      end subroutine
!
!-----------------------------------------------------------------------
      subroutine mfft1cr(fc,f,mixup,sct,tfft,indx)
! wrapper function for scalar 1d complex to real FFT
! input fc is complex, output f is real
      implicit none
      integer, intent(in) :: indx
      complex, dimension(:), intent(in) :: fc
      real, dimension(:), intent(inout) :: f
      integer, dimension(:), intent(in) :: mixup
      complex, dimension(:), intent(in) :: sct
      real, intent(inout) :: tfft
! local data
      integer :: j, n, isign, nxd, nxhd
      integer, dimension(4) :: itime
      double precision :: dtime
! extract dimensions
      isign = 1
      n = size(fc,1)
      nxd = size(f,1)
      nxhd = size(mixup,1)
! check if required size of buffer has increased
      if (szt < nxhd) then
         if (szt /= 0) deallocate(t)
! allocate new buffers
         allocate(t(nxhd))
         szt = nxhd
      endif
! initialize timer
      call dtimer(dtime,itime,-1)
      if (nxd.ge.(2*n)) then
         do j = 1, n
            f(2*j-1) = real(fc(j))
            f(2*j) = aimag(fc(j))
         enddo
      else
         write (*,*) 'mfft1cr f too small: nxd, 2*n = ', nxd, 2*n
      endif
! call low level procedure
      call FFT1RXX(f,t,isign,mixup,sct,indx,nxd,nxhd)
! record time
      call dtimer(dtime,itime,1)
      tfft = tfft + real(dtime)
      end subroutine
!
!-----------------------------------------------------------------------
      subroutine mfft1crn(fc,f,mixup,sct,tfft,indx)
! wrapper function for n component vector 1d complex to real FFT
! input fc is complex, output f is real
      implicit none
      integer, intent(in) :: indx
      complex, dimension(:,:), intent(in) :: fc
      real, dimension(:,:), intent(inout) :: f
      integer, dimension(:), intent(in) :: mixup
      complex, dimension(:), intent(in) :: sct
      real, intent(inout) :: tfft
! local data
      integer :: j, n, m, isign, ndim, nxd, nxhd
      integer, dimension(4) :: itime
      double precision :: dtime
! extract dimensions
      isign = 1
      m = size(fc,1); n = size(fc,2)
      ndim = size(f,1); nxd = size(f,2)
      nxhd = size(mixup,1)
      if (m /= ndim) then
         write (*,*) 'mfft1crn invalid vectors: ndim, m = ', ndim, m
      else if (nxd.lt.(2*n)) then
         write (*,*) 'mfft1crn f too small: nxd, 2*n = ', nxd, 2*n
      endif
! check if required size of buffer has increased
      if (szt < ndim*nxhd) then
         if (szt /= 0) deallocate(t)
! allocate new buffers
         allocate(t(ndim*nxhd))
         szt = ndim*nxhd
      endif
! initialize timer
      call dtimer(dtime,itime,-1)
! call low level procedure
      select case(ndim)
      case (2)
         do j = 1, n
            f(1,2*j-1) = real(fc(1,j))
            f(2,2*j-1) = aimag(fc(1,j))
            f(1,2*j) = real(fc(2,j))
            f(2,2*j) = aimag(fc(2,j))
         enddo
         call FFT1R2X(f,t,isign,mixup,sct,indx,nxd,nxhd)
      case (3)
         do j = 1, n
            f(1,2*j-1) = real(fc(1,j))
            f(2,2*j-1) = aimag(fc(1,j))
            f(3,2*j-1) = real(fc(2,j))
            f(1,2*j) = aimag(fc(2,j))
            f(2,2*j) = real(fc(3,j))
            f(3,2*j) = aimag(fc(3,j))
         enddo
         call FFT1R3X(f,t,isign,mixup,sct,indx,nxd,nxhd)
      end select
! record time
      call dtimer(dtime,itime,1)
      tfft = tfft + real(dtime)
      end subroutine
!
      end module


      SUBROUTINE QDMM2 (TEMPS,PG)
C
C     THERMAL LOAD GENERATION FOR THE QDMEM2 ELEMENT.
C
C     ELEMENT EST ENTRY CONTENTS
C     + + + + + + + + + + + + + + + + + + + + + + + + + +
C     +   1 = ID                                        +
C     +   2 = SIL-PT-A            (ELEMENT CONNECTS     +
C     +   3 = SIL-PT-B             GRID POINTS A,B,     +
C     +   4 = SIL-PT-C             C,D IN THAT ORDER)   +
C     +   5 = SIL-PT-D                                  +
C     +   6 = MATERIAL-ANGLE                            +
C     +   7 = MATERIAL-ID                               +
C     +   8 = THICKNESS OF ELEMENT                      +
C     +   9 = NON-STRUCTURAL-MASS                       +
C     +  10 = COORD-SYS-ID PT-A OR 0                    +
C     +  11 = XA                                        +
C     +  12 = YA                                        +
C     +  13 = ZA                                        +
C     +  14 = COORD-SYS-ID PT-B OR 0                    +
C     +  15 = XB                                        +
C     +  16 = YB                                        +
C     +  17 = ZB                                        +
C     +  18 = COORD-SYS-ID PT-C OR 0                    +
C     +  19 = XC                                        +
C     +  20 = YC                                        +
C     +  21 = ZC                                        +
C     +  22 = COORD-SYS-ID PT-D OR 0                    +
C     +  23 = XD                                        +
C     +  24 = YD                                        +
C     +  25 = ZD                                        +
C     +  26 = AVERAGE OF CONNECTED GRID TEMPERATURES    +
C     + + + + + + + + + + + + + + + + + + + + + + + + + +
C
      LOGICAL         PLANAR
      INTEGER         NEST(7),MAP(4,3)
      REAL            RMAT(3,5),ET(9),K5SUM(9,5),ISINTH,KMAT(27),
     1                ITEMP9(9),ALPHA(3),PMAT(9),JTEMP9(9),ICOSTH,
     2                GSUBE(9),TEMPS(1),PG(1),PSUM(3,5),IT
      CHARACTER       UFM*23,UWM*25
      COMMON /XMSSG / UFM,UWM
      COMMON /MATIN / MATID, INFLAG, ELTEMP, STRESS, SINTH, COSTH
      COMMON /MATOUT/ G11,G12,G13,G22,G23,G33, RHO, ALPS(3), TSUB0
      COMMON /SYSTEM/ KSYSTM(65)
      COMMON /TRIMEX/ EST(26)
      COMMON /CONDAS/ PI,TWOPI,RADEG,DEGRA,S4PISQ
      EQUIVALENCE     (KSYSTM(2),IOUTPT),(NEST(1),EST(1))
      DATA    MAP   / 1, 2, 3, 4,
     1                2, 3, 4, 1,
     2                5, 5, 5, 5 /
C
C     COMPUTE BASIC SIN AND COSINE OF ELEMENT MATERIAL ANGLE.
C
      ANGL   = EST(6)*DEGRA
      ISINTH = SIN(ANGL)
      ICOSTH = COS(ANGL)
C
C     COMPUTE GSUBE MATRIX
C
      INFLAG = 2
      MATID  = NEST(7)
      ELTEMP = EST(26)
      SINTH  = 0.0
      COSTH  = 1.0
      CALL MAT (NEST(1))
      GSUBE(1) = G11
      GSUBE(2) = G12
      GSUBE(3) = G13
      GSUBE(4) = G12
      GSUBE(5) = G22
      GSUBE(6) = G23
      GSUBE(7) = G13
      GSUBE(8) = G23
      GSUBE(9) = G33
C
C     FORM  ALPHA = ALPS *(T-T )  3X1 VECTOR USED IN SUB-TRIANGLE CALCS
C                       E     0
C
      TBAR     = TEMPS(1) - TSUB0
      ALPHA(1) = ALPS(1)*TBAR
      ALPHA(2) = ALPS(2)*TBAR
      ALPHA(3) = ALPS(3)*TBAR
C
C     NOTE THE ABOVE MAY BE MOVED TO BELOW AND COMPUTED USING THE
C     GRID TEMPS OF SUB-TRIANGLE.  (I.E. TOTAL AVERAGE FOR CENTER POINT
C     ONLY.)  AVERAGE OF WHOLE ELEMENT IS USED EXCLUSIVELY NOW.
C
C     BASIC WHOLE-ELEMENT CALCULATIONS
C
      CALL Q2BCS (EST,PLANAR,RMAT,ET,IERROR)
      IF (IERROR) 10,10,140
C
C     ZERO SUMMATION ARRAYS
C
   10 DO 30 I = 1,5
      DO 20 J = 1,9
      K5SUM(J,I) = 0.0
   20 CONTINUE
      PSUM(1,I) = 0.0
      PSUM(2,I) = 0.0
      PSUM(3,I) = 0.0
   30 CONTINUE
C
C     SUB-TRIANGLE COMPUTATIONS AND SUMMATIONS.
C
      DO 70 I = 1,4
      IA = MAP(I,1)
      IB = MAP(I,2)
      IC = MAP(I,3)
      IT = EST(8)
      CALL Q2TRMS (RMAT(1,IA),RMAT(1,IB),RMAT(1,IC),ALPHA(1),ISINTH,
     1             ICOSTH,GSUBE,IT,IERROR,2,KMAT,PMAT,DUMMY,DUMMY)
      IF (IERROR) 40,40,140
C
C     SUM IN KCA,KCB,KCC
C
   40 DO 50 K = 1,9
      K5SUM(K,IA) = K5SUM(K,IA) + KMAT(K   )
      K5SUM(K,IB) = K5SUM(K,IB) + KMAT(K+ 9)
      K5SUM(K,IC) = K5SUM(K,IC) + KMAT(K+18)
   50 CONTINUE
C
C     SUM IN PA,PB,PC
C
      DO 60 K = 1,3
      PSUM(K,IA) = PSUM(K,IA) + PMAT(K  )
      PSUM(K,IB) = PSUM(K,IB) + PMAT(K+3)
      PSUM(K,IC) = PSUM(K,IC) + PMAT(K+6)
   60 CONTINUE
C
   70 CONTINUE
C
C     IF -PLANAR- MODIFY THE K5SUM MATRICES.
C
      IF (.NOT.PLANAR) GO TO 90
      DO 80 I = 1,5
      K5SUM(7,I) = 0.0
      K5SUM(8,I) = 0.0
      K5SUM(9,I) =-0.25
   80 CONTINUE
      K5SUM(9,5) = 1.0
C
C     INVERT K   AND NEGATE THE RESULT.
C             55
C
   90 CONTINUE
C
C     NO NEED TO COMPUTE DETERMINANT SINCE IT IS NOT USED SUBSEQUENTLY.
C
      ISING = -1
      CALL INVERS (3,K5SUM(1,5),3,DUMMY,0,DETERM,ISING,ITEMP9)
      IF (ISING .EQ. 2) GO TO 140
C
      DO 100 I = 1,9
      K5SUM(I,5) = -K5SUM(I,5)
  100 CONTINUE
C
C     4 (3X1) LOAD VECTORS ARE COMPUTED AND ADDED INTO THE P-VECTOR IN
C     CORE
C
C       G        T   T                  -1      T
C     (P ) = (T ) (E) ((PSUM ) + ((-K  ) (K  )) (PSUM ))
C       I      I            I        55    5I        5
C
      DO 130 I = 1,4
      CALL GMMATS (K5SUM(1,5),3,3,0,K5SUM(1,I),3,3,0,ITEMP9)
      CALL GMMATS (ITEMP9,3,3,1,PSUM(1,5),3,1,0,JTEMP9)
      DO 110 J = 1,3
      PSUM(J,I) = PSUM(J,I) + JTEMP9(J)
  110 CONTINUE
      CALL GMMATS (ET,3,3,1,PSUM(1,I),3,1,0,JTEMP9)
      JTEMP9(4) = 0.0
      JTEMP9(5) = 0.0
      JTEMP9(6) = 0.0
      K = 4*I + 6
      IF (NEST(K) .NE. 0) CALL BASGLB (JTEMP9,JTEMP9,NEST(K+1),NEST(K))
C
C     ADD LOAD TO CORE FOR THIS GRID
C                                   I
      L = NEST(I+1)
      DO 120 J = 1,3
      PG(L) = PG(L) + JTEMP9(J)
      L = L + 1
  120 CONTINUE
C
  130 CONTINUE
      RETURN
C
C     ERROR CONDITIONS
C
  140 WRITE  (IOUTPT,150) UWM,NEST(1)
  150 FORMAT (A25,' 3100, ELEMENT THERMAL LOAD COMPUTATION FOR QDMEM2 ',
     1       'ELEMENT ID =',I9, /5X,'FINDS ILLEGAL GEOMETRY THUS NO ',
     2       'LOADS OUTPUT FOR ELEMENT-ID NOTED.')
      RETURN
      END


C
C $Id: tdinit.f,v 1.5 2008-07-27 00:17:32 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      SUBROUTINE TDINIT (XMID,YMID,ZMID,XORI,YORI,ZORI,XTHI,YTHI,ZTHI,
     +                   OTEP)
C
C This routine initializes the projection package.  The arguments are
C as follows:
C
C   (XMID,YMID,ZMID) is a point in three-space that is midway between
C   the eyes of the observer.
C
C   (XORI,YORI,ZORI) is a point in three-space at the origin of a plane
C   called "plane 1", which is the image plane; plane 1 passes through
C   the point (XORI,YORI,ZORI) and is perpendicular to the line joining
C   (XMID,YMID,ZMID) to (XORI,YORI,ZORI).
C
C   (XTHI,YTHI,ZTHI) is the third of three points in three-space [the
C   other two being (XMID,YMID,ZMID) and (XORI,YORI,ZORI)] required to
C   define a plane called "plane 2", which is the plane of bilateral
C   symmetry of the user.  The intersection of planes 1 and 2 is the Y
C   axis of the image plane.  A plane called "plane 3" is defined as
C   passing through the point (XORI,YORI,ZORI) and being perpendicular
C   to each of planes 1 and 2.  The intersection of planes 1 and 3 is
C   the X axis of the image plane.
C
C   OTEP is the desired offset to the position of the eye to be used.
C   If the distance between the eyes is "s", then use OTEP = "-s/2" for
C   a left-eye view and OTEP = "+s/2" for a right-eye view.  OTEP = 0
C   gives a Cyclopean view from the point (XMID,YMID,ZMID).
C
C If the common variable IH has the value zero, the 3D coordinate system
C is right-handed; if it has a non-zero value, the coordinate system is
C left-handed.
C
C If the common variable IS has the value zero, no SET call is done;
C otherwise, a SET call is done, defining a field of view of FV degrees,
C where FV is another common variable.
C
C If one half of a stereo pair is being done and the common variable
C IT is non-zero, planes 1, 2, and 3 are redefined (by rotation about
C the Y axis) so that plane 1 is perpendicular to the line from the
C eye being used to the point (XORI,YORI,ZORI); planes 2 and 3 also
C pass through the eye being used.
C
C The variables in the following common block define the mapping from
C 3-space to 2-space.
C
        COMMON /TDCOM1/ IH,IT,XM,YM,ZM,XO,YO,ZO,XT,YT,ZT,OE,XE,YE,ZE
        COMMON /TDCOM1/ A1,B1,C1,D1,E1,A2,B2,C2,D2,E2,A3,B3,C3,D3,E3
        COMMON /TDCOM1/ IS,FV,VL,VR,VB,VT,WL,WR,WB,WT
        SAVE   /TDCOM1/
C
C Do a call forcing a BLOCKDATA to be loaded from a binary library.
C
        CALL TDBLDA
C
C Check for an uncleared prior error.
C
        IF (ICFELL('TDINIT - UNCLEARED PRIOR ERROR',1).NE.0) RETURN
C
C Copy the coordinates of the midpoint of the line joining the eyes
C into labelled common.
C
        XM=XMID
        YM=YMID
        ZM=ZMID
C
C Copy the coordinates of the origin of the image plane into labelled
C common.
C
        XO=XORI
        YO=YORI
        ZO=ZORI
C
C Copy the coordinates of the third point into labelled common.
C
        XT=XTHI
        YT=YTHI
        ZT=ZTHI
C
C Copy the offset to the eye position into labelled common.
C
        OE=OTEP
C
C Compute the coefficients in the equation defining plane 1.
C
        A1=XO-XM
        B1=YO-YM
        C1=ZO-ZM
        D1=XO*XM+YO*YM+ZO*ZM-XO*XO-YO*YO-ZO*ZO
        T1=SQRT(A1*A1+B1*B1+C1*C1)
        A1=A1/T1
        B1=B1/T1
        C1=C1/T1
        D1=D1/T1
C
C Compute the coefficients in the equation defining plane 2.
C
        A2=YM*(ZO-ZT)+YO*(ZT-ZM)+YT*(ZM-ZO)
        B2=XM*(ZT-ZO)+XO*(ZM-ZT)+XT*(ZO-ZM)
        C2=XM*(YO-YT)+XO*(YT-YM)+XT*(YM-YO)
        D2=XM*YT*ZO+XO*YM*ZT+XT*YO*ZM-XM*YO*ZT-XT*YM*ZO-XO*YT*ZM
        T2=SQRT(A2*A2+B2*B2+C2*C2)
        IF (IH.NE.0) T2=-T2
        A2=A2/T2
        B2=B2/T2
        C2=C2/T2
        D2=D2/T2
C
C Compute the coefficients in the equation defining plane 3.
C
        A3=B2*(ZO-ZM)+C2*(YM-YO)
        B3=A2*(ZM-ZO)+C2*(XO-XM)
        C3=A2*(YO-YM)+B2*(XM-XO)
        D3=A2*(YM*ZO-YO*ZM)+B2*(XO*ZM-XM*ZO)+C2*(XM*YO-XO*YM)
        T3=SQRT(A3*A3+B3*B3+C3*C3)
        IF (IH.NE.0) T3=-T3
        A3=A3/T3
        B3=B3/T3
        C3=C3/T3
        D3=D3/T3
C
C Call SET, if that is to be done.
C
        IF (IS.NE.0) THEN
          IF (VR-VL.GT.VT-VB) THEN
            WL=-ABS(A1*XM+B1*YM+C1*ZM+D1)*TAN(.017453292519943*FV/2.)
            WR=-WL
            WB=((VT-VB)/(VR-VL))*WL
            WT=-WB
          ELSE
            WB=-ABS(A1*XM+B1*YM+C1*ZM+D1)*TAN(.017453292519943*FV/2.)
            WT=-WB
            WL=((VR-VL)/(VT-VB))*WB
            WR=-WL
          END IF
          CALL SET (VL,VR,VB,VT,WL,WR,WB,WT,1)
          IF (ICFELL('TDINIT',2).NE.0) RETURN
        END IF
C
C Compute the coordinates of the eye position.
C
        XE=XM+A2*OE
        YE=YM+B2*OE
        ZE=ZM+C2*OE
C
C If a stereo view is being done and the user has requested that the
C image plane for each view be perpendicular to the line of sight from
C the eye in use, recompute all quantities to make it so.
C
        IF (OE.NE.0..AND.IT.NE.0) THEN
          TT=ABS(A1*XE+B1*YE+C1*ZE+D1)
          XS=XO+TT*A3
          YS=YO+TT*B3
          ZS=ZO+TT*C3
          A1=XO-XE
          B1=YO-YE
          C1=ZO-ZE
          D1=XO*XE+YO*YE+ZO*ZE-XO*XO-YO*YO-ZO*ZO
          T1=SQRT(A1*A1+B1*B1+C1*C1)
          A1=A1/T1
          B1=B1/T1
          C1=C1/T1
          D1=D1/T1
          A2=YE*(ZO-ZS)+YO*(ZS-ZE)+YS*(ZE-ZO)
          B2=XE*(ZS-ZO)+XO*(ZE-ZS)+XS*(ZO-ZE)
          C2=XE*(YO-YS)+XO*(YS-YE)+XS*(YE-YO)
          D2=XE*YS*ZO+XO*YE*ZS+XS*YO*ZE-XE*YO*ZS-XS*YE*ZO-XO*YS*ZE
          T2=SQRT(A2*A2+B2*B2+C2*C2)
          IF (IH.NE.0) T2=-T2
          A2=A2/T2
          B2=B2/T2
          C2=C2/T2
          D2=D2/T2
          A3=B2*(ZO-ZE)+C2*(YE-YO)
          B3=A2*(ZE-ZO)+C2*(XO-XE)
          C3=A2*(YO-YE)+B2*(XE-XO)
          D3=A2*(YE*ZO-YO*ZE)+B2*(XO*ZE-XE*ZO)+C2*(XE*YO-XO*YE)
          T3=SQRT(A3*A3+B3*B3+C3*C3)
          IF (IH.NE.0) T3=-T3
          A3=A3/T3
          B3=B3/T3
          C3=C3/T3
          D3=D3/T3
        END IF
C
C Compute quantities needed by TDPRPT.
C
        E1=A1*XE+B1*YE+C1*ZE+D1
        E2=A2*XE+B2*YE+C2*ZE+D2
        E3=A3*XE+B3*YE+C3*ZE+D3
C
C Done.
C
        RETURN
C
      END


! python c:\python27\scripts\f2py.py -c -m fgmel gmel.f90 --fcompiler=gnu95 -lnlopt -lm
MODULE DATA
  IMPLICIT NONE
  REAL*8, ALLOCATABLE :: Y(:), X(:,:), Z(:,:), V(:)
END MODULE DATA

SUBROUTINE ESTIMATE(BETA,VCOV,H,Y1,X1,Z1,V1,T,K,M,J)
  USE DATA
  IMPLICIT NONE
  integer T, K, M, J
  REAL*8, INTENT(OUT), DIMENSION(K) :: BETA
  REAL*8, INTENT(OUT), DIMENSION(K,K) :: VCOV
  REAL*8, INTENT(OUT) :: H
  REAL*8, INTENT(IN), DIMENSION(T) :: Y1
  REAL*8, INTENT(IN), DIMENSION(T,K) :: X1
  REAL*8, INTENT(IN), DIMENSION(K,M) :: Z1
  REAL*8, INTENT(IN), DIMENSION(J) :: V1
  INTEGER*8 opt
  REAL*8 LB(T), UB(T), MAXH, lamest(T), DELTAS, OMES
  REAL*8 P(K,M), W(T,J), OMEGA(K,M), OMEGAS(K), LAM0(T), XOUT(K,K), XOUTINV(K,K)
  INTEGER IRES
  EXTERNAL DUAL_OBJ
  INCLUDE 'nlopt.f'
  Y = Y1
  X = X1
  Z = Z1
  V = V1
  lb = -1.0D5
  ub = 1.0D5
  LAM0 = 0.0D0
  CALL NLO_CREATE(OPT,NLOPT_LD_TNEWTON,T)
  CALL nlo_set_lower_bounds(ires, opt, lb)
  call nlo_set_upper_bounds(ires, opt, ub)
  call nlo_set_vector_storage(ires, opt, 200)
  call nlo_set_min_objective(ires, opt, DUAL_OBJ, 0)
  call nlo_set_xtol_rel(ires, opt, 1.0D-10)
  lamest = lam0
  call nlo_optimize(ires, opt, LAMEST, MAXH)
  call nlo_destroy(opt)
  OMEGA=EXP(-Z*SPREAD(MATMUL(TRANSPOSE(X),LAMEST),2,M))
  OMEGAS = SUM(OMEGA,2)
  P = OMEGA/SPREAD(OMEGAS,2,M)
  BETA = SUM(Z*P,2)
  H = MAXH
  W = EXP(-1*MATMUL(RESHAPE(LAMEST,(/T,1/)),RESHAPE(V,(/1,J/))))/ &
      spread(sum(EXP(-1*MATMUL(RESHAPE(LAMEST,(/T,1/)),RESHAPE(V,(/1,J/)))),2),2,J)
  DELTAS = SUM(LAMEST**2)/T
  OMES = (SUM(1/(sum((spread(v,1,T)**2)*W,2)-(sum(spread(v,1,T)*W,2))**2))/T)**2
  XOUT = MATMUL(TRANSPOSE(X),X)
  CALL inverse(XOUT,XOUTINV,K)
  VCOV = (DELTAS/OMES)*XOUTINV
  RETURN
end subroutine estimate

SUBROUTINE DUAL_OBJ(OBJ, T, LAM, GRAD, NEED_GRADIENT)
  USE DATA
  IMPLICIT NONE
  REAL*8 OBJ, LAM(T), GRAD(T)
  INTEGER T, NEED_GRADIENT, M, J
  M = SIZE(Z,2)
  J = SIZE(V)

  if (need_gradient.ne.0) then
  grad = y - matmul(x,SUM(Z*EXP(-Z*SPREAD(MATMUL(TRANSPOSE(X),LAM),2,M)) &
         /SPREAD(SUM(EXP(-Z*SPREAD(MATMUL(TRANSPOSE(X),LAM),2,M)),2),2,M),2)) - &
         sum(spread(v,1,T)*EXP(-1*MATMUL(RESHAPE(LAM,(/T,1/)),RESHAPE(V,(/1,J/))))/ &
         spread(sum(EXP(-1*MATMUL(RESHAPE(LAM,(/T,1/)),RESHAPE(V,(/1,J/)))),2),2,J),2)
  endif

  OBJ = DOT_PRODUCT(Y,LAM) + &
        SUM(LOG(SUM(EXP(-Z*SPREAD(MATMUL(TRANSPOSE(X),LAM),2,M)),2))) + &
        SUM(LOG(SUM(EXP(-1*MATMUL(RESHAPE(LAM,(/T,1/)),RESHAPE(V,(/1,J/)))),2)))
  RETURN
END SUBROUTINE DUAL_OBJ

 subroutine inverse(a,c,n)
!============================================================
! Inverse matrix
! Method: Based on Doolittle LU factorization for Ax=b
! Alex G. December 2009
!-----------------------------------------------------------
! input ...
! a(n,n) - array of coefficients for matrix A
! n      - dimension
! output ...
! c(n,n) - inverse matrix of A
! comments ...
! the original matrix a(n,n) will be destroyed
! during the calculation
!===========================================================
implicit none
integer n
double precision a(n,n), c(n,n)
double precision L(n,n), U(n,n), b(n), d(n), x(n)
double precision coeff
integer i, j, k

! step 0: initialization for matrices L and U and b
! Fortran 90/95 aloows such operations on matrices
L=0.0
U=0.0
b=0.0

! step 1: forward elimination
do k=1, n-1
   do i=k+1,n
      coeff=a(i,k)/a(k,k)
      L(i,k) = coeff
      do j=k+1,n
         a(i,j) = a(i,j)-coeff*a(k,j)
      enddo
   enddo
enddo

! Step 2: prepare L and U matrices
! L matrix is a matrix of the elimination coefficient
! + the diagonal elements are 1.0
do i=1,n
  L(i,i) = 1.0
enddo
! U matrix is the upper triangular part of A
do j=1,n
  do i=1,j
    U(i,j) = a(i,j)
  enddo
enddo

! Step 3: compute columns of the inverse matrix C
do k=1,n
  b(k)=1.0
  d(1) = b(1)
! Step 3a: Solve Ld=b using the forward substitution
  do i=2,n
    d(i)=b(i)
    do j=1,i-1
      d(i) = d(i) - L(i,j)*d(j)
    enddo
  enddo
! Step 3b: Solve Ux=d using the back substitution
  x(n)=d(n)/U(n,n)
  do i = n-1,1,-1
    x(i) = d(i)
    do j=n,i+1,-1
      x(i)=x(i)-U(i,j)*x(j)
    enddo
    x(i) = x(i)/u(i,i)
  enddo
! Step 3c: fill the solutions x(n) into column k of C
  do i=1,n
    c(i,k) = x(i)
  end do
  b(k)=0.0
enddo
end subroutine inverse