C ****************************************************************************
C FILE: mpi_heat2D.f
C OTHER FILES: draw_heatf.c mpi_heat2D.h
C DESCRIPTION:
C   HEAT2D Example - Parallelized Fortran Version
C   This example is based on a simplified two-dimensional heat
C   equation domain decomposition.  The initial temperature is computed to be
C   high in the middle of the domain and zero at the boundaries.  The
C   boundaries are held at zero throughout the simulation.  During the
C   time-stepping, an array containing two domains is used; these domains
C   alternate between old data and new data.
C
C   In this parallelized version, the grid is decomposed by the master
C   process and then distributed by cols to workers processes.  At each
C   time step, workers processes must exchange border data with neighbors,
C   because a grid point's current temperature depends upon it's previous
C   time step value plus the values of the neighboring grid points.  Upon
C   completion of all time steps, the worker processes return their results
C   to the master process.
C
C   Two data files are produced: an initial data set and a final data set.
C   An X graphic of these two states displays after all calculations have
C   completed.
C
C AUTHOR: Blaise Barney - adapted from D. Turner's serial C version. Converted
C   to MPI: George L. Gusciora (1/95)
C LAST REVISED: 06/12/13 Blaise Barney
C ****************************************************************************
C Explanation of constants and variables
C   NXPROB                         =  x dimension of problem grid
C   NYPROB                         =  y dimension of problem grid
C   STEPS                          =  number of time steps
C   MAXWORKER                      =  maximum number of workers tasks
C   MINWORKER                      =  minimum number of workers tasks
C   BEGIN, LTAG, RTAG, DONE        =  message tags
C   NONE                           =  indicates no neighbor
C   CX, CY                         =  used in heat equation
C   u                              =  array for grids
C   taskid,MASTER                  =  taskids
C   numworkers                     =  number of workers processes
C   numtasks                       =  number of tasks
C   avecol,cols,offset,extra       =  for sending cols of data
C   dest, source                   =  to - from for message send-receive
C   left,right                     =  neighbor tasks
C   msgtype                        =  for message types
C   rc,start,end                   =  misc
C   i,ix,iy,iz,it                  =  loop variables
C ---------------------------------------------------------------------------

      program heat2D
      include 'mpif.h'
      include 'mpi_heat2D.h'

C     Routine for creating the X graph of the wave
      external draw_heat

      integer STEPS,MAXWORKER,MINWORKER,BEGIN,LTAG,RTAG,DONE,
     .        NONE,MASTER
      parameter(STEPS=50)
      parameter(MAXWORKER=8)
      parameter(MINWORKER=3)
      parameter(BEGIN=1)
      parameter(LTAG=2)
      parameter(RTAG=3)
      parameter(DONE=4)
      parameter(NONE=0)
      parameter(MASTER=0)
      integer taskid,numtasks,numworkers,avecol,cols,offset,extra,
     &        dest,source,left,right,msgtype,
     &        rc,start,end,i,ix,iy,iz,it,ierr
      integer status(MPI_STATUS_SIZE)

C     First, find out my taskid and how many tasks are running */
      call MPI_INIT( ierr )
      call MPI_COMM_RANK( MPI_COMM_WORLD, taskid, ierr )
      call MPI_COMM_SIZE( MPI_COMM_WORLD, numtasks, ierr )
      numworkers = numtasks-1

      if (taskid .eq. MASTER) then
C     ****************************** master code *****************************
C     Check if numworkers is within range - quit if not
      if ((numworkers.lt.MINWORKER).or.(numworkers.gt.MAXWORKER)) then
        print *,'MP_PROCS needs to be between', MINWORKER+1,'and',
     .           MAXWORKER+1, 'for this exercise'
        print *,'Quitting...'
        call MPI_ABORT(MPI_COMM_WORLD, rc, ierr)
      end if

      print *, 'Starting mpi_heat2D with',numworkers,'worker tasks.'

C     Initialize grid
      print *,'Grid size: X=',NXPROB,' Y=',NYPROB,' Time steps=',STEPS
      print *,'Initializing grid and writing initial.dat file...'
      call inidat
      call prtdat(1)

C     Distribute work to workers.  Must first figure out how many cols to
C     send and what to do with extra cols.
      avecol=NYPROB/numworkers
      extra=mod(NYPROB,numworkers)
      offset=1
      do i=1, numworkers
        if (i .le. extra) then
          cols=avecol+1
        else
          cols=avecol
        end if
C       Tell each worker which other workers are its neighbors, since
C       they must exchange data with each other later.
        if (i .eq. 1) then
          left=NONE
        else
          left=i-1
        end if
        if (i .eq. numworkers) then
          right=NONE
        else
          right=i+1
        end if
C       Now send startup information to each worker
        dest = i
      call MPI_SEND( offset, 1, MPI_INTEGER, dest, BEGIN,
     &               MPI_COMM_WORLD, ierr )
      call MPI_SEND( cols, 1, MPI_INTEGER, dest, BEGIN,
     &               MPI_COMM_WORLD, ierr )
      call MPI_SEND( left, 1, MPI_INTEGER, dest, BEGIN,
     &               MPI_COMM_WORLD, ierr )
      call MPI_SEND( right, 1, MPI_INTEGER, dest, BEGIN,
     &               MPI_COMM_WORLD, ierr )
      call MPI_SEND( u(1,offset,1), cols * NXPROB, MPI_REAL, dest,
     &               BEGIN, MPI_COMM_WORLD, ierr )
        print *,'Sent to=',dest,'offset=',offset,'cols=',cols,
     .    'left=',left,'right=',right
        offset = offset + cols
      end do

C     Now wait for results from all workers tasks
      do i=1, numworkers
        source = i
        msgtype = DONE
        call MPI_RECV( offset, 1, MPI_INTEGER, source,
     &                 msgtype, MPI_COMM_WORLD, status, ierr )
        call MPI_RECV( cols, 1, MPI_INTEGER, source,
     &                 msgtype, MPI_COMM_WORLD, status, ierr )
        call MPI_RECV( u(1,offset,1), cols * NXPROB, MPI_REAL,
     &                 source,msgtype,MPI_COMM_WORLD,status,ierr)
      end do

C     Print and show results
      print *,'Creating final.dat file and generating graph...'
      call prtdat(2)
      call draw_heat()

C     End of master code
      call MPI_FINALIZE(ierr)
      end if

      if (taskid .ne. MASTER)  then
C     ****************************** worker code ******************************
C     Initialize everything - including the borders - to zero
      do ix=1,NXPROB
        do iy=1,NYPROB
          do iz=1,2
            u(ix,iy,iz) = 0.0
          end do
        end do
      end do

C     Now receive my offset, cols, neighbors and grid partition from master
      source = MASTER
      msgtype = BEGIN
      call MPI_RECV( offset, 1, MPI_INTEGER, source,
     &                 msgtype, MPI_COMM_WORLD, status, ierr )
      call MPI_RECV( cols, 1, MPI_INTEGER, source,
     &                 msgtype, MPI_COMM_WORLD, status, ierr )
      call MPI_RECV( left, 1, MPI_INTEGER, source,
     &                 msgtype, MPI_COMM_WORLD, status, ierr )
      call MPI_RECV( right, 1, MPI_INTEGER, source,
     &                 msgtype, MPI_COMM_WORLD, status, ierr )
      call MPI_RECV( u(1,offset,1),cols*NXPROB,MPI_REAL, source,
     &                 msgtype, MPI_COMM_WORLD, status, ierr )

C     Determine border elements.  Need to consider first and last columns.
C     Obviously, col 1 can't exchange with col 1-1.  Likewise, the last
C     col can't exchange with last+1.
      start=offset
      end=offset+cols-1
      if (offset .eq. 1) then
        start=2
      end if
      if (offset + cols .gt. NYPROB) then
        end=end-1
      end if
      print *,'task=',taskid,'  start=',start,'  end=',end

C     Begin doing STEPS iterations.  Must communicate border cols with
C     neighbors.  If I have the first or last grid col, then I only need to
C     communicate with one neighbor.
      iz=1
      do it=1, STEPS
        if (left .ne. NONE) then
          call MPI_SEND( u(1,offset,iz), NXPROB, MPI_REAL, left,
     &                   RTAG, MPI_COMM_WORLD, ierr )

          source = left
          msgtype = LTAG
          call MPI_RECV( u(1,offset-1,iz),NXPROB,MPI_REAL, source,
     &                   msgtype, MPI_COMM_WORLD, status, ierr )
        end if

        if (right .ne. NONE) then
          call MPI_SEND(u(1,offset+cols-1,iz),NXPROB,MPI_REAL,
     &                  right,LTAG,MPI_COMM_WORLD,ierr)

          source = right
          msgtype = RTAG
          call MPI_RECV(u(1,offset+cols,iz),NXPROB,MPI_REAL,source,
     &                   msgtype, MPI_COMM_WORLD, status, ierr )
        end if

C       Now call update to update the value of grid points
        call update(start,end,u(1,1,iz),u(1,1,3-iz))

        iz=3-iz
      end do

C     Send my portion of final results back to master
      call MPI_SEND( offset, 1, MPI_INTEGER, MASTER, DONE,
     &               MPI_COMM_WORLD, ierr )
      call MPI_SEND( cols, 1, MPI_INTEGER, MASTER, DONE,
     &               MPI_COMM_WORLD, ierr )
      call MPI_SEND( u(1,offset,iz),cols*NXPROB,MPI_REAL,MASTER,
     &               DONE, MPI_COMM_WORLD, ierr )

C     End of worker code
      call MPI_FINALIZE(ierr)
      end if

      end

C****************************************************************************
      subroutine update (start, end, u1, u2)
C****************************************************************************
      include 'mpi_heat2D.h'
      integer start, end, ix, iy
      real*4 u1, u2
      dimension u1(NXPROB,NYPROB),u2(NXPROB,NYPROB)

      do iy=start, end
        do ix=2, NXPROB-1
            u2(ix,iy) = u1(ix,iy)
     .       + CX * ( u1(ix+1,iy) + u1(ix-1,iy) - 2.0 * u1(ix,iy))
     .       + CY * ( u1(ix,iy+1) + u1(ix,iy-1) - 2.0 * u1(ix,iy))
        end do
      end do
	  end

C*****************************************************************************
      subroutine inidat
C*****************************************************************************
      include 'mpi_heat2D.h'
      integer ix,iy

      do ix=0,NXPROB-1
        do iy=0,NYPROB-1
          u(ix+1,iy+1,1) = float(ix*(NXPROB-ix-1) * iy*(NYPROB-iy-1))
        end do
      end do
      end

C**************************************************************************
      subroutine prtdat(i)
C**************************************************************************
      include 'mpi_heat2D.h'
      integer i,ix, iy
      character*11 fname

      if (i .eq. 1) then
        fname ='initial.dat'
      else if (i .eq. 2) then
        fname = 'final.dat'
      end if

      open(21, file=fname, form='formatted')
      do ix=1,NXPROB
        do iy=1,NYPROB
          write(21,'(f8.1,1x,$)')u(ix,iy,1)
        end do
        write(21,'(1x)')
      end do
      close(21)
      end


PROGRAM mcjy01

! Code converted using TO_F90 by Alan Miller
! Date: 2004-06-28  Time: 12:58:10

!       ================================================================
!       Purpose: This program computes Bessel functions J0(z), J1(z),
!                Y0(z), Y1(z), and their derivatives for a complex
!                argument using subroutine CJY01
!       Input :  z --- Complex argument
!       Output:  CBJ0 --- J0(z)
!                CDJ0 --- J0'(z)
!                CBJ1 --- J1(z)
!                CDJ1 --- J1'(z)
!                CBY0 --- Y0(z)
!                CDY0 --- Y0'(z)
!                CBY1 --- Y1(z)
!                CDY1 --- Y1'(z)
!       Example: z =  4.0 + i  2.0

!     n     Re[Jn(z)]       Im[Jn(z)]       Re[Jn'(z)]      Im[Jn'(z)]
!   --------------------------------------------------------------------
!     0  -.13787022D+01   .39054236D+00   .50735255D+00   .12263041D+01
!     1  -.50735255D+00  -.12263041D+01  -.11546013D+01   .58506793D+00

!     n     Re[Yn(z)]       Im[Yn(z)]       Re[Yn'(z)]      Im[Yn'(z)]
!   --------------------------------------------------------------------
!     0  -.38145893D+00  -.13291649D+01  -.12793101D+01   .51220420D+00
!     1   .12793101D+01  -.51220420D+00  -.58610052D+00  -.10987930D+01
!       ================================================================

IMPLICIT DOUBLE PRECISION (x,y)
IMPLICIT COMPLEX*16 (c,z)
WRITE(*,*)'  Please enter x,y (z=x+iy) '
!        READ(*,*)X,Y
x=4.0
y=2.0
z=CMPLX(x,y)
WRITE(*,30)x,y
CALL cjy01(z,cbj0,cdj0,cbj1,cdj1,cby0,cdy0,cby1,cdy1)
WRITE(*,*)
WRITE(*,*)'  n      Re[Jn(z)]       Im[Jn(z)]',  &
    '       Re[Jn''(Z)]      IM[JN''(Z)]'
WRITE(*,*)' -------------------------------------',  &
    '-------------------------------'
WRITE(*,10)cbj0,cdj0
WRITE(*,20)cbj1,cdj1
WRITE(*,*)
WRITE(*,*)'  n      Re[Yn(z)]       Im[Yn(z)]',  &
    '       Re[Yn''(Z)]      IM[YN''(Z)]'
WRITE(*,*)' -------------------------------------',  &
    '-------------------------------'
WRITE(*,10)cby0,cdy0
WRITE(*,20)cby1,cdy1
10      FORMAT(3X,'0',2X,4D16.8)
20      FORMAT(3X,'1',2X,4D16.8)
30      FORMAT(3X,3HZ =,f6.2,' + i',f6.2)
END PROGRAM mcjy01

SUBROUTINE cjy01(z,cbj0,cdj0,cbj1,cdj1,cby0,cdy0,cby1,cdy1)

!       =======================================================
!       Purpose: Compute Bessel functions J0(z), J1(z), Y0(z),
!                Y1(z), and their derivatives for a complex
!                argument
!       Input :  z --- Complex argument
!       Output:  CBJ0 --- J0(z)
!                CDJ0 --- J0'(z)
!                CBJ1 --- J1(z)
!                CDJ1 --- J1'(z)
!                CBY0 --- Y0(z)
!                CDY0 --- Y0'(z)
!                CBY1 --- Y1(z)
!                CDY1 --- Y1'(z)
!       =======================================================

COMPLEX, INTENT(IN)                      :: z
COMPLEX, INTENT(OUT)                     :: cbj0
COMPLEX, INTENT(OUT)                     :: cdj0
COMPLEX, INTENT(OUT)                     :: cbj1
COMPLEX, INTENT(OUT)                     :: cdj1
COMPLEX, INTENT(OUT)                     :: cby0
COMPLEX, INTENT(OUT)                     :: cdy0
COMPLEX, INTENT(OUT)                     :: cby1
COMPLEX, INTENT(OUT)                     :: cdy1
IMPLICIT DOUBLE PRECISION (a,b,e,p,r,w)
IMPLICIT COMPLEX*16 (c,z)
DIMENSION a(12),b(12),a1(12),b1(12)

pi=3.141592653589793D0
el=0.5772156649015329D0
rp2=2.0D0/pi
ci=(0.0D0,1.0D0)
a0=CDABS(z)
z2=z*z
z1=z
IF (a0 == 0.0D0) THEN
  cbj0=(1.0D0,0.0D0)
  cbj1=(0.0D0,0.0D0)
  cdj0=(0.0D0,0.0D0)
  cdj1=(0.5D0,0.0D0)
  cby0=-(1.0D300,0.0D0)
  cby1=-(1.0D300,0.0D0)
  cdy0=(1.0D300,0.0D0)
  cdy1=(1.0D300,0.0D0)
  RETURN
END IF
IF (REAL(z) < 0.0) z1=-z
IF (a0 <= 12.0) THEN
  cbj0=(1.0D0,0.0D0)
  cr=(1.0D0,0.0D0)
  DO  k=1,40
    cr=-0.25D0*cr*z2/(k*k)
    cbj0=cbj0+cr
    IF (CDABS(cr) < CDABS(cbj0)*1.0D-15) EXIT
  END DO
  15         cbj1=(1.0D0,0.0D0)
  cr=(1.0D0,0.0D0)
  DO  k=1,40
    cr=-0.25D0*cr*z2/(k*(k+1.0D0))
    cbj1=cbj1+cr
    IF (CDABS(cr) < CDABS(cbj1)*1.0D-15) EXIT
  END DO
  25         cbj1=0.5D0*z1*cbj1
  w0=0.0D0
  cr=(1.0D0,0.0D0)
  cs=(0.0D0,0.0D0)
  DO  k=1,40
    w0=w0+1.0D0/k
    cr=-0.25D0*cr/(k*k)*z2
    cp=cr*w0
    cs=cs+cp
    IF (CDABS(cp) < CDABS(cs)*1.0D-15) EXIT
  END DO
  35         cby0=rp2*(CDLOG(z1/2.0D0)+el)*cbj0-rp2*cs
  w1=0.0D0
  cr=(1.0D0,0.0D0)
  cs=(1.0D0,0.0D0)
  DO  k=1,40
    w1=w1+1.0D0/k
    cr=-0.25D0*cr/(k*(k+1))*z2
    cp=cr*(2.0D0*w1+1.0D0/(k+1.0D0))
    cs=cs+cp
    IF (CDABS(cp) < CDABS(cs)*1.0D-15) EXIT
  END DO
  45         cby1=rp2*((CDLOG(z1/2.0D0)+el)*cbj1-1.0D0/z1-.25D0*z1*cs)
ELSE
  DATA a/-.703125D-01,.112152099609375D+00,  &
      -.5725014209747314D+00,.6074042001273483D+01,  &
      -.1100171402692467D+03,.3038090510922384D+04,  &
      -.1188384262567832D+06,.6252951493434797D+07,  &
      -.4259392165047669D+09,.3646840080706556D+11,  &
      -.3833534661393944D+13,.4854014686852901D+15/
  DATA b/ .732421875D-01,-.2271080017089844D+00,  &
      .1727727502584457D+01,-.2438052969955606D+02,  &
      .5513358961220206D+03,-.1825775547429318D+05,  &
      .8328593040162893D+06,-.5006958953198893D+08,  &
      .3836255180230433D+10,-.3649010818849833D+12,  &
      .4218971570284096D+14,-.5827244631566907D+16/
  DATA a1/.1171875D+00,-.144195556640625D+00,  &
      .6765925884246826D+00,-.6883914268109947D+01,  &
      .1215978918765359D+03,-.3302272294480852D+04,  &
      .1276412726461746D+06,-.6656367718817688D+07,  &
      .4502786003050393D+09,-.3833857520742790D+11,  &
      .4011838599133198D+13,-.5060568503314727D+15/
  DATA b1/-.1025390625D+00,.2775764465332031D+00,  &
      -.1993531733751297D+01,.2724882731126854D+02,  &
      -.6038440767050702D+03,.1971837591223663D+05,  &
      -.8902978767070678D+06,.5310411010968522D+08,  &
      -.4043620325107754D+10,.3827011346598605D+12,  &
      -.4406481417852278D+14,.6065091351222699D+16/
  k0=12
  IF (a0 >= 35.0) k0=10
  IF (a0 >= 50.0) k0=8
  ct1=z1-.25D0*pi
  cp0=(1.0D0,0.0D0)
  DO  k=1,k0
    cp0=cp0+a(k)*z1**(-2*k)
  END DO
  cq0=-0.125D0/z1
  DO  k=1,k0
    cq0=cq0+b(k)*z1**(-2*k-1)
  END DO
  cu=CDSQRT(rp2/z1)
  cbj0=cu*(cp0*CDCOS(ct1)-cq0*CDSIN(ct1))
  cby0=cu*(cp0*CDSIN(ct1)+cq0*CDCOS(ct1))
  ct2=z1-.75D0*pi
  cp1=(1.0D0,0.0D0)
  DO  k=1,k0
    cp1=cp1+a1(k)*z1**(-2*k)
  END DO
  cq1=0.375D0/z1
  DO  k=1,k0
    cq1=cq1+b1(k)*z1**(-2*k-1)
  END DO
  cbj1=cu*(cp1*CDCOS(ct2)-cq1*CDSIN(ct2))
  cby1=cu*(cp1*CDSIN(ct2)+cq1*CDCOS(ct2))
END IF
IF (REAL(z) < 0.0) THEN
  IF (DIMAG(z) < 0.0) cby0=cby0-2.0D0*ci*cbj0
  IF (DIMAG(z) > 0.0) cby0=cby0+2.0D0*ci*cbj0
  IF (DIMAG(z) < 0.0) cby1=-(cby1-2.0D0*ci*cbj1)
  IF (DIMAG(z) > 0.0) cby1=-(cby1+2.0D0*ci*cbj1)
  cbj1=-cbj1
END IF
cdj0=-cbj1
cdj1=cbj0-1.0D0/z*cbj1
cdy0=-cby1
cdy1=cby0-1.0D0/z*cby1
RETURN
END SUBROUTINE cjy01


!******************************************************************
! Module used by dcv_deconv_2D.f90
!
!  spdiv => Direct spectral division
!  wiene => Wiener filter
!  tikho => Tikhonov regularisation
!  maxen => Maximum Entropy method
!
! JLP
! Version 28/03/2001
!******************************************************************
module dcv_2D_mod
use dcv_2D_data
implicit none
 private

 public		:: dcv_wiener,dcv_spdiv,dcv_mem,dcv_sqrtrf
 public		:: dcv_tikhonov,dcv_ggauss,dcv_gmark
 public		:: dcv_conv_hh,func,dfunc
! Needed for L curve:
 public		:: phi_ggauss,phi_gmark,phi_tikho,phi_sqrtrf,phi_mem
 private	:: dphi_ggauss,dphi_gmark,dphi_tikho,dphi_sqrtrf,dphi_mem
 private 	:: dcv_check_grad

!------------------
! For dcv_2D_mod:
! ss2 is a parameter needed for convex sqrt regularization
 real,private			:: ss2
! used for calibrating constants
 real,private			:: gscale=1.e6

!------------------
! For dcv_cgrad_mod:
 integer,private		:: ncom
 real,private,dimension(idim)	:: pcom,xicom
 public				:: frprmn
 private			:: norm_l2,linmin,df1dim,f1dim,mnbrak,dbrent

contains
!*************************************************************
! Deconvolution with Gauss-Markov regularisation
! Criterium to minimize is:
! || y - H x ||^2 + alpha phi
!
! with:
!        _
!        \                     p                      p
! phi =  / | x        - x     |  + | x       - x     |
!        -    (i+1,j)    (i,j)        (i,j+1)   (i,j)
!        i
! (Smooth function, which reduces the variation between two successive pixels)
!*************************************************************
subroutine dcv_gmark(iter)
 integer        	:: iter,i,j
 real			:: ftol,fret

! Compute transfer function:
hh_re = hh; hh_im = 0.;
call fft_float(hh_re,hh_im,nx,ny,1);

! Compute FFT function of reversed PSF (i.e., PSF(-x)):
do j=1,ny
  do i=1,nx
   hht_re(i + j*nx) = hh((nx - (i-1)) + (ny - (j-1))*nx)
  end do
end do
hht_im = 0.;
call fft_float(hht_re,hht_im,nx,ny,1);

! Check if gradient is OK
!call dcv_check_grad(yyd,w0,w1,nn)

! Starting point:
    yyd = 0.
! Tolerance
    ftol=1.e-6
    call frprmn(yyd,nn,ftol,iter,fret)
    write(6,11) iter,fret
11  format(" Number of iterations:",I4,/,&
           " Value of the minimum:",E12.5)
return
end subroutine dcv_gmark
!*************************************************************
! Regularisation function to be minimized for Gauss-Markov
!        _
!        \                     p                      p
! phi =  / | x        - x     |  + | x       - x     |
!        -    (i+1,j)    (i,j)        (i,j+1)   (i,j)
!        i
! (Smooth function, which reduces the variation between two successive pixels)
!*************************************************************
real function phi_gmark(xx)
 real,dimension(nx,ny)	:: xx
 double precision	:: dx,dy,ssum
 integer		:: i,j

ssum = 0.
! Central part:
do j=1,ny-1
  do i=1,nx-1
     dx = xx(i+1,j) - xx(i,j)
     dy = xx(i,j+1) - xx(i,j)
     ssum = ssum + dx*dx + dy*dy
  end do
end do
! Wrap the image for the edges
! Last line
do i=1,nx-1
     dx = xx(i+1,ny) - xx(i,ny)
     dy = xx(i,1) - xx(i,ny)
     ssum = ssum + dx*dx + dy*dy
end do
! Last column
do j=1,ny-1
     dx = xx(1,j) - xx(nx,j)
     dy = xx(nx,j+1) - xx(nx,j)
     ssum = ssum + dx*dx + dy*dy
end do
! Last pixel
     dx = xx(1,ny) - xx(nx,ny)
     dy = xx(nx,1) - xx(nx,ny)
     ssum = ssum + dx*dx + dy*dy

phi_gmark = real(ssum)

return
end function phi_gmark
!*************************************************************
! Gradient of potential function for Gauss-Markov
!        _
!        \                     p                      p
! phi =  / | x        - x     |  + | x       - x     |
!        -    (i+1,j)    (i,j)        (i,j+1)   (i,j)
!        i
! (Smooth function, which reduces the variation between two successive pixels)
!
!*************************************************************
subroutine dphi_gmark(xx,dx)
 integer		:: i,j
 real,dimension(nx,ny)	:: xx,dx

! Gradient is linear, so
! First go along the lines
do i=2,nx-1
  do j=1,ny
   dx(i,j) = - 2*(xx(i+1,j)-xx(i,j)) + 2*(xx(i,j)-xx(i-1,j))
  end do
end do
! First and last pixels of each line:
do j=1,ny
   dx(1,j) = - 2*(xx(2,j)-xx(1,j)) + 2*(xx(1,j)-xx(nx,j))
   dx(nx,j) = - 2*(xx(1,j)-xx(nx,j)) + 2*(xx(nx,j)-xx(nx-1,j))
end do

! Then go along the columns:
do i=1,nx
  do j=2,ny-1
   dx(i,j) = dx(i,j) - 2*(xx(i,j+1)-xx(i,j)) + 2*(xx(i,j)-xx(i,j-1))
  end do
end do
! First and last pixels of each column:
do i=1,nx
   dx(i,1) = dx(i,1) - 2*(xx(i,2)-xx(i,1)) + 2*(xx(i,1)-xx(i,ny))
   dx(i,ny) = dx(i,ny) - 2*(xx(i,1)-xx(i,ny)) + 2*(xx(i,ny)-xx(i,ny-1))
end do

 return
end subroutine dphi_gmark
!*************************************************************
! Deconvolution with MEM
! Criterium to minimize is:
! || y - H x ||^2 + alpha Sigma_{k=1}^{k=N} x_k^2
!*************************************************************
subroutine dcv_mem(iter)
 integer        	:: iter,i,j
 real			:: ftol,fret

! Compute transfer function:
hh_re = hh; hh_im = 0.;
call fft_float(hh_re,hh_im,nx,ny,1);

! Compute FFT function of reversed PSF (i.e., PSF(-x)):
do i=1,nx
  do j=1,ny
   hht_re(i + j*nx) = hh((nx - (i-1)) + (ny - (j-1))*nx)
  end do
end do
hht_im = 0.;
call fft_float(hht_re,hht_im,nx,ny,1);

! Starting point:
    yyd = 0.
! Tolerance
    ftol=1.e-6
    call frprmn(yyd,nn,ftol,iter,fret)
    write(6,11) iter,fret
11  format(" Number of iterations:",I4,/,&
           " Value of the minimum:",E12.5)
return
end subroutine dcv_mem
!*************************************************************
! Regularisation function to be minimized for MEM
! Entropy potential function:
!        _
!        \
! phi =  /   x log(x )
!        -    i     i
!        i
!*************************************************************
real function phi_mem(xx)
 real,dimension(idim)	:: xx

where(xx > 0.)
  w1 = xx*log(xx);
elsewhere
  w1 = 1000.*gscale;
endwhere

phi_mem = sum(w1)

return
end function phi_mem
!*************************************************************
! Gradient of potential function for MEM
!        _
!        \
! phi =  /   x log(x )
!        -    i     i
! => dphi = sum(1 + log(x)):
!*************************************************************
subroutine dphi_mem(xx,dx)
 real,dimension(idim)	:: xx,dx

where(xx > 0.)
  dx = 1. + log(xx);
elsewhere
! Next statement is wrong:
!  dx = -1000.*gscale;
! So I leave it:
  dx = -1000.;
endwhere

 return
end subroutine dphi_mem
!*************************************************************
! Deconvolution by Tikhonov's regularisation
! Criterium to minimize is:
! || y - H x ||^2 + alpha Sigma_{k=1}^{k=N} x_k^2
! (Carfantan: grf)
!*************************************************************
subroutine dcv_tikhonov(iter)
 integer        	:: iter,i,j
 real			:: ftol,fret

! Compute transfer function:
hh_re = hh; hh_im = 0.;
call fft_float(hh_re,hh_im,nx,ny,1);

! Compute FFT function of reversed PSF (i.e., PSF(-x)):
do j=1,ny
  do i=1,nx
   hht_re(i + j*nx) = hh((nx - (i-1)) + (ny - (j-1))*nx)
  end do
end do
hht_im = 0.;
call fft_float(hht_re,hht_im,nx,ny,1);

! Check if gradient is OK
!call dcv_check_grad(yyd,w0,w1,nn)

! Starting point:
    yyd = 0.
! Tolerance
    ftol=1.e-6
    call frprmn(yyd,nn,ftol,iter,fret)
    write(6,11) iter,fret
11  format(" Number of iterations:",I4,/,&
           " Value of the minimum:",E12.5)
return
end subroutine dcv_tikhonov
!*************************************************************
! Regularisation function to be minimized for Tikhonov
! Bauman & Sauer's potential function, with p=2
!        _
!        \        p
! phi =  /  | x  |
!        -     i
!        i
!  phi = sum(abs(real(x(:))).^p);
!  dphi = p*sign(x).*(abs(real(x)).^(p-1));
!*************************************************************
real function phi_tikho(xx)
 real,dimension(idim)	:: xx

phi_tikho = sum(xx**2)

return
end function phi_tikho
!*************************************************************
! Gradient of potential function for Tikhonov's regularisation:
! Bauman & Sauer's potential function, with p=2
!        _
!        \        p
! phi =  /  | x  |
!        -     i
!        i
!  dphi = p*sign(x).*(abs(real(x)).^(p-1));
! here: dphi = 2 x
!
!*************************************************************
subroutine dphi_tikho(xx,dx)
 real,dimension(idim)	:: xx,dx

 dx = 2*xx

 return
end subroutine dphi_tikho
!*************************************************************
! Deconvolution by generalized Gauss' regularisation
! Criterium to minimize is:
! || y - H x ||^2 + alpha Sigma_{k=1}^{k=N} x_k^p
! with p=1.1
! (Carfantan: ggrf)
!*************************************************************
subroutine dcv_ggauss(iter)
 integer        	:: iter,i,j
 real			:: ftol,fret

! Compute transfer function:
hh_re = hh; hh_im = 0.;
call fft_float(hh_re,hh_im,nx,ny,1);

! Compute FFT function of reversed PSF (i.e., PSF(-x)):
do j=1,ny
  do i=1,nx
   hht_re(i + j*nx) = hh((nx - (i-1)) + (ny - (j-1))*nx)
  end do
end do
hht_im = 0.;
call fft_float(hht_re,hht_im,nx,ny,1);

! Starting point:
    yyd = 0.
! Tolerance
    ftol=1.e-6
    call frprmn(yyd,nn,ftol,iter,fret)
    write(6,11) iter,fret
11  format(" Number of iterations:",I4,/,&
           " Value of the minimum:",E12.5)
return
end subroutine dcv_ggauss
!*************************************************************
! Regularisation function to be minimized for generalized Gauss
! Bauman & Sauer's potential function, with p=1.1
!        _
!        \        p
! phi =  /  | x  |
!        -     i
!        i
!  phi = sum(abs(real(x(:))).^p);
!  dphi = p*sign(x).*(abs(real(x)).^(p-1));
!*************************************************************
real function phi_ggauss(xx)
 real,dimension(idim)	:: xx

phi_ggauss = sum(abs(xx)**1.1)

return
end function phi_ggauss
!*************************************************************
! Gradient of potential function for generalized Gauss' regularisation:
! Bauman & Sauer's potential function, with p=1.1
!        _
!        \        p
! phi =  /  | x  |
!        -     i
!        i
!  dphi = p*sign(x).*(abs(real(x)).^(p-1));
! here: dphi = 1.1 x**0.1
!
!*************************************************************
subroutine dphi_ggauss(xx,dx)
 real,dimension(idim)	:: xx,dx

where(xx > 0.)
  w1 = xx**0.1
elsewhere
  w1 = -((-xx)**0.1)
end where
 dx = 1.1*w1

 return
end subroutine dphi_ggauss
!*************************************************************
! Deconvolution by generalized Gauss' regularisation
! Criterium to minimize is:
!             || y - H x ||^2 + alpha phi
! with:
!        _      __________
!        \     /  2     2 |
! phi =  / \  / ss  +  x
!        -  \/           i
!        i
! (Carfantan: sqrtrf, with ss=0.01 or ss=0.001)
!*************************************************************
subroutine dcv_sqrtrf(ss,iter)
 integer        	:: iter,i,j
 real			:: ss,ftol,fret

! Set ss2 (private parameter) to the value chosen when calling the routine:
ss2 = ss*ss

! Compute transfer function:
hh_re = hh; hh_im = 0.;
call fft_float(hh_re,hh_im,nx,ny,1);

! Compute FFT function of reversed PSF (i.e., PSF(-x)):
do j=1,ny
  do i=1,nx
   hht_re(i + j*nx) = hh((nx - (i-1)) + (ny - (j-1))*nx)
  end do
end do
hht_im = 0.;
call fft_float(hht_re,hht_im,nx,ny,1);

! Starting point:
    yyd = 0.
! Tolerance
    ftol=1.e-6
    call frprmn(yyd,nn,ftol,iter,fret)
    write(6,11) iter,fret
11  format(" Number of iterations:",I4,/,&
           " Value of the minimum:",E12.5)
return
end subroutine dcv_sqrtrf
!*************************************************************
! Regularisation function to be minimized for sqrt(s^2+x^2)
!        _      __________
!        \     /  2     2 |
! phi =  / \  / ss  +  x
!        -  \/           i
!        i
! (Carfantan: sqrtrf, with ss=0.01 or ss=0.001)
!*************************************************************
real function phi_sqrtrf(xx)
 real,dimension(idim)	:: xx

phi_sqrtrf = sum(sqrt(ss2 + xx**2))

return
end function phi_sqrtrf
!*************************************************************
! Gradient of potential function for convex sqrt(s^2+x^2) regularisation:
!        _      __________
!        \     /  2     2 |
! phi =  / \  / ss  +  x
!        -  \/           i
!        i
! (Carfantan: sqrtrf, with ss=0.01 or ss=0.001)
!
!*************************************************************
subroutine dphi_sqrtrf(xx,dx)
 real,dimension(idim)	:: xx,dx

 dx = xx/sqrt(ss2+xx**2)

 return
end subroutine dphi_sqrtrf
!*********************************************************
! Function E to be minimized for deconvolution
!
! This subroutine returns   E = |Y-Ax|^2 + alpha  phi
!
!*********************************************************
real function func(xx)
! integer,parameter	:: idim=256
 real,dimension(idim)	:: xx
! The following statement makes the program crash
! real,dimension(:)	:: xx
 real			:: phi
 integer 		:: i

! Convolution = product in Fourier domain:
! w0 = convolution of xx with hh:
call dcv_conv_hh(xx,hh_re,hh_im,w0)
w0 = w0 - yy

select case(option)
  case('tikho')
    phi = phi_tikho(xx)
  case('maxen')
    phi = phi_mem(xx)
  case('ggaus')
    phi = phi_ggauss(xx)
  case('gmark')
    phi = phi_gmark(xx)
  case('sqrtr')
    phi = phi_sqrtrf(xx)
  case default
    print *,' func/Fatal error: invalid option'
    stop
end select

if(positivity)then
  do i = 1,nn
   if(xx(i) < 0.) phi = phi + 1000.*gscale
  end do
endif
func = sum(w0**2) + alpha * phi

return
end function func
!*********************************************************
! Gradient of potential function for minimisation:
! grad_Er : value of the gradient of the criterium in X
!                                       (                 \---
! This subroutine returns  grad(E) =grad( |Y-Ax|^2+ alpha  >    phi(Xs-Xr)
!                                       (                 /___
!                                                      (s,r) in C
!
! d/dx (HX - Y)^T (HX - Y) = 2 H^T (HX - Y)
!*********************************************************
subroutine dfunc(xx,dx)
! integer,parameter	:: idim=256
 real,dimension(idim)	:: xx,dx
! The following statement makes the program crash
! real,dimension(:)	:: xx,dx

! Convolution = product in Fourier domain:
! w0 = conv(xx,hh):
call dcv_conv_hh(xx,hh_re,hh_im,w0)

dx = w0 - yy;

! w0 = conv(xx,hht):
call dcv_conv_hh(dx,hht_re,hht_im,w0)

select case(option)
  case('tikho')
    call dphi_tikho(xx,dx)
  case('maxen')
    call dphi_mem(xx,dx)
  case('ggaus')
    call dphi_ggauss(xx,dx)
  case('gmark')
    call dphi_gmark(xx,dx)
  case('sqrtr')
    call dphi_sqrtrf(xx,dx)
  case default
    print *,' dfunc/Fatal error: invalid option'
    stop
end select

if(positivity)then
  where(xx < 0.) dx = -1000.
endif
 dx = 2*w0 + alpha*dx
 return
end subroutine dfunc
!*************************************************************
! Deconvolution by Wiener filter
!*************************************************************
subroutine dcv_wiener

! Compute FFT of signal:
yy_re = yy; yy_im = 0.;
call fft_float(yy_re,yy_im,nx,ny,1);

! Compute transfer function:
hh_re = hh; hh_im = 0.;
call fft_float(hh_re,hh_im,nx,ny,1);

w0 = hh_re*hh_re + hh_im*hh_im;

! 1/(a+ib) = (a-ib)/(a2+b2)
! Wiener filter = ((a2+b2) / ((a2+b2) + alpha)) / (a+ib)
! Hence:        = (a-ib) / ((a2+b2) + alpha))
 w_re = hh_re / (w0 + alpha);
 w_im = - hh_im / (w0 + alpha);

! Deconvolution:
w0 = w_re*yy_re - w_im*yy_im
w1 = w_re*yy_im + w_im*yy_re
call fft_float(w0,w1,nx,ny,-1);
yyd = 0.; yyd(1:nn) = w0(1:nn)

return
end subroutine dcv_wiener
!*************************************************************
! Deconvolution by spectral division
!*************************************************************
subroutine dcv_spdiv

! Compute FFT of signal:
yy_re = yy; yy_im = 0.;
call fft_float(yy_re,yy_im,nx,ny,1);

! Compute transfer function:
hh_re = hh; hh_im = 0.;
call fft_float(hh_re,hh_im,nx,ny,1);

w0 = hh_re*hh_re + hh_im*hh_im;

! 1/(a+ib) = (a-ib)/(a2+b2)
w_re = 0.; w_im = 0.;
where(w0 /= 0.)
 w_re = hh_re / w0;
 w_im = - hh_im / w0;
end where

! Deconvolution:
w0 = w_re*yy_re - w_im*yy_im
w1 = w_re*yy_im + w_im*yy_re
call fft_float(w0,w1,nx,ny,-1);
yyd = 0.; yyd(1:nn) = w0(1:nn)

return
end subroutine dcv_spdiv
!*************************************************************
! Convolution H*X :  w0 = conv(xx,hh)
!
! IN:
! xx: function to be convolved by hh
! hh_re, hh_im: TF of hh
!
! OUT:
! ww = conv(hh,xx)  WARNING: often ww=w0 in the calling program...
!
!*************************************************************
subroutine dcv_conv_hh(xx,hh_re,hh_im,ww)
 real,dimension(idim)	:: xx,hh_re,hh_im,ww

! Convolution = product in Fourier domain:

! Compute FFT of xx:
w_re = xx; w_im = 0.;
call fft_float(w_re,w_im,nx,ny,1);

! Product in Fourier domain:
ww = w_re*hh_re - w_im*hh_im
w1 = w_re*hh_im + w_im*hh_re

! Back to direct space:
call fft_float(ww,w1,nx,ny,-1);

return
end subroutine dcv_conv_hh
!*************************************************************
! Check the validity of the gradient
! and compare f(x+dx)-f(x)/dx with grad_f(x)
!
! x1,x2,dx: work space of dimension nn
!*************************************************************
subroutine dcv_check_grad(x1,x2,dx,nn)
 integer                :: nn,i
 real,parameter		:: eps=1.e-4,tolerance=1.e-4
 real			:: f_x2,f_x1,error
 real,dimension(idim)    :: x1,x2,dx

print *,' dcv_check_grad/Start checking gradient (Warning: may take some time...)'

! Generate random vector (between 0 and 1)
call random_seed;
call random_number(x1);
f_x1 = func(x1)

! Loop on all components:
!do i=1,nn
! Loop on a subsample (since too long otherwise):
do i=1000,1010
   x2 = x1;
   x2(i) = x1(i) + eps
   f_x2 = func(x1)
   call dfunc(x1,dx)
   error = (f_x2 - f_x1)/eps - dx(i)*eps
   error = error / abs(f_x1 + 1.e-12)
   if(error > tolerance)then
      print *,'dcv_check_grad/Error!'
      write(6,12) i,error
12    format('i=',I4,' relative error =',E10.4)
   endif
end do

print *,' dcv_check_grad/End checking gradient'

return
end subroutine dcv_check_grad
!
!end module dcv_2D_mod
!***************************************************************
! module with frprmn
! Minimization of "func" with gradient "dfunc"
!
!***************************************************************
!module dcv_cgrad
! private
!! integer,parameter      	:: idim=256
!
! integer,private		:: ncom
! real,private,dimension(idim)	:: pcom,xicom
! public				:: frprmn
! private			:: norm_l2,linmin,df1dim,f1dim,mnbrak,dbrent
!
!contains
!*********************************************************
! Flechter-Reeves-Polak-Ribiere minimization
! Cf "Numerical recipees" Sect. 10.6 (in C p 423, in F77 p 416)
! IN:
! p: first guess
! n = dimension of p
! ftol = tolerance
! OUT:
! p: location of minimum
! iter: nber of iterations
! fret: value of minimum
!
! Given a starting point p that is a vector of length n
! Flechter-Reeves-Polak-Ribiere minimization is performed on
! a function func, using its gradient as calculated by a routine dfunc.
! The convergence tolerance on the function value is input as ftol.
! Return quantities are p (the location of the minimum),
! iter (the number of iterations that were performed)
! and fret (the minimum value of the function).
! The routine linmin is called to perform line minimizations.
!********************************************************
      subroutine frprmn(p,n,ftol,iter,fret)
! itmax: maximum allowed number of iterations
! eps: small number to rectify the special case
! of converging to exactly zero function value
      integer itmax,j,iter,n
      real gam,gg,dgg,fret,ftol,eps,fp,norm_p,norm_p0
      real crit_fp,crit_p
      parameter (itmax=1000,eps=1.e-10)
      real p(n),g(idim),h(idim),xi(idim),p0(idim)
! Before
!      real func
!      external func
!      real norm_l2
!      external norm_l2
! Initializations:
      fp=func(p)
      call dfunc(p,xi)
      do 11 j=1,n
        g(j)=-xi(j)
        h(j)=g(j)
        xi(j)=h(j)
11    continue
      do 14 iter=1,itmax
        do j=1,n
          p0(j) = p(j)
        end do
        call linmin(p,xi,n,fret)
        do j=1,n
          p0(j) = p0(j) - p(j)
        end do
        norm_p0 = norm_l2(p0,n)
        norm_p = norm_l2(p,n)
        crit_p = norm_p0 / (norm_p+eps)
        crit_fp = 2.*abs(fret-fp)/(abs(fret)+abs(fp)+eps)
! For simulations every 10 iterations was OK, but not for real data...
!        if(mod(iter,10).eq.1)then
          write(6,18) iter,crit_p,crit_fp
18	  format('Iter=',I3,' Rel. variation p=',e10.3,' fp=',e10.3)
!        endif
! Next statement is normal return:
! Exit criterium is 2 * |fret-fp| < ftol * (|fret| + |fp| + eps)
! i.e. relative variation of fp is small:
! 2 * |fret-fp| / (|fret| + |fp| + eps) < ftol
!  which is nearly: |fret-fp| / |fret| < ftol
!        if(2.*abs(fret-fp).le.ftol*(abs(fret)+abs(fp)+eps))return
! JLP 2001
! I also put a constraint on the variations of p
        if((crit_fp.le.ftol).and.(crit_p.le.ftol)) return
        fp=func(p)
        call dfunc(p,xi)
        gg=0.
        dgg=0.
        do 12 j=1,n
          gg=gg+g(j)**2
! Flechter-Reeves:
!         dgg=dgg+xi(j)**2
! Polak-Ribiere: (better)
          dgg=dgg+(xi(j)+g(j))*xi(j)
12      continue
! Unlikely: if gradient is exactly zero, then we are already done.
        if(gg.eq.0.)then
            write(6,*)'frprmn/return since gradient is null: gg=0'
            return
        endif
        gam=dgg/gg
        do 13 j=1,n
          g(j)=-xi(j)
          h(j)=g(j)+gam*h(j)
          xi(j)=h(j)
13      continue
14    continue
      write(6,*) 'frprmn/maximum iterations exceeded: iter=',iter
      return
      end subroutine frprmn
!************************************************************
! Norm L2
!************************************************************
real function norm_l2(p,n)
  integer 		:: n,j
  real,dimension(n)	:: p(n)
      norm_l2 = 0.
      do j=1,n
        norm_l2 = norm_l2 + p(j)*p(j)
      end do
      return
end function norm_l2
!************************************************************
! Search for minimum along a given direction
!************************************************************
subroutine linmin(p,xi,n,fret)
  integer		:: n,j
  real,parameter 	:: tol=1.e-4
  real,dimension(n)	:: p,xi
  real			:: fret,ax,xx,bx,xmin,fx,fa,fb
      ncom=n
      do j=1,n
        pcom(j)=p(j)
        xicom(j)=xi(j)
      end do
      ax=0.
      xx=1.
      bx=2.
      call mnbrak(ax,xx,bx,fa,fx,fb,f1dim)
      fret=dbrent(ax,xx,bx,f1dim,df1dim,tol,xmin)
      do j=1,n
        xi(j)=xmin*xi(j)
        p(j)=p(j)+xi(j)
      end do
      return
end subroutine linmin
!**************************************************************
real function df1dim(x)
  real,dimension(idim) 	:: xt,df
  integer		:: j
  real			:: x
      do 11 j=1,ncom
        xt(j)=pcom(j)+x*xicom(j)
11    continue
      call dfunc(xt,df)
      df1dim=0.
      do 12 j=1,ncom
        df1dim=df1dim+df(j)*xicom(j)
12    continue
      return
end function df1dim
!**************************************************************
real function f1dim(x)
  real,dimension(idim) 	:: xt
  integer		:: j
  real			:: x
      do 11 j=1,ncom
        xt(j)=pcom(j)+x*xicom(j)
11    continue
      f1dim=func(xt)
      return
      end function f1dim
!**************************************************************
subroutine mnbrak(ax,bx,cx,fa,fb,fc,func)
real,parameter 		:: gold=1.618034,glimit=100.,tiny=1.e-20
real			:: fa,fb,fc,func,fu,dum,ax,bx,cx
real			:: r,q,u,ulim
      fa=func(ax)
      fb=func(bx)
      if(fb.gt.fa)then
        dum=ax
        ax=bx
        bx=dum
        dum=fb
        fb=fa
        fa=dum
      endif
      cx=bx+gold*(bx-ax)
      fc=func(cx)
1     if(fb.ge.fc)then
        r=(bx-ax)*(fb-fc)
        q=(bx-cx)*(fb-fa)
        u=bx-((bx-cx)*q-(bx-ax)*r)/(2.*sign(max(abs(q-r),tiny),q-r))
        ulim=bx+glimit*(cx-bx)
        if((bx-u)*(u-cx).gt.0.)then
          fu=func(u)
          if(fu.lt.fc)then
            ax=bx
            fa=fb
            bx=u
            fb=fu
            go to 1
          else if(fu.gt.fb)then
            cx=u
            fc=fu
            go to 1
          endif
          u=cx+gold*(cx-bx)
          fu=func(u)
        else if((cx-u)*(u-ulim).gt.0.)then
          fu=func(u)
          if(fu.lt.fc)then
            bx=cx
            cx=u
            u=cx+gold*(cx-bx)
            fb=fc
            fc=fu
            fu=func(u)
          endif
        else if((u-ulim)*(ulim-cx).ge.0.)then
          u=ulim
          fu=func(u)
        else
          u=cx+gold*(cx-bx)
          fu=func(u)
        endif
        ax=bx
        bx=cx
        cx=u
        fa=fb
        fb=fc
        fc=fu
        go to 1
      endif
      return
end subroutine mnbrak
!**************************************************************
real function dbrent(ax,bx,cx,ff,dff,tol,xmin)
  integer,parameter	:: itmax=100
  real,parameter	:: zeps=1.0e-10
  logical		:: ok1,ok2
  integer		:: iter
  real			:: a,b,d,e,olde,u,v,w,x
  real			:: ax,bx,cx,ff,dff,tol,xmin,d1,d2,dv,dx,dw
  real			:: du,fu,fv,fx,fw,u1,u2
  real			:: xm,tol1,tol2
      a=min(ax,cx)
      b=max(ax,cx)
      v=bx
      w=v
      x=v
      e=0.
      fx=ff(x)
      fv=fx
      fw=fx
      dx=dff(x)
      dv=dx
      dw=dx
      do 11 iter=1,itmax
        xm=0.5*(a+b)
        tol1=tol*abs(x)+zeps
        tol2=2.*tol1
        if(abs(x-xm).le.(tol2-.5*(b-a))) goto 3
        if(abs(e).gt.tol1) then
          d1=2.*(b-a)
          d2=d1
          if(dw.ne.dx) d1=(w-x)*dx/(dx-dw)
          if(dv.ne.dx) d2=(v-x)*dx/(dx-dv)
          u1=x+d1
          u2=x+d2
          ok1=((a-u1)*(u1-b).gt.0.).and.(dx*d1.le.0.)
          ok2=((a-u2)*(u2-b).gt.0.).and.(dx*d2.le.0.)
          olde=e
          e=d
          if(.not.(ok1.or.ok2))then
            go to 1
          else if (ok1.and.ok2)then
            if(abs(d1).lt.abs(d2))then
              d=d1
            else
              d=d2
            endif
          else if (ok1)then
            d=d1
          else
            d=d2
          endif
          if(abs(d).gt.abs(0.5*olde))go to 1
          u=x+d
          if(u-a.lt.tol2 .or. b-u.lt.tol2) d=sign(tol1,xm-x)
          goto 2
        endif
1       if(dx.ge.0.) then
          e=a-x
        else
          e=b-x
        endif
        d=0.5*e
2       if(abs(d).ge.tol1) then
          u=x+d
          fu=ff(u)
        else
          u=x+sign(tol1,d)
          fu=ff(u)
          if(fu.gt.fx)go to 3
        endif
        du=dff(u)
        if(fu.le.fx) then
          if(u.ge.x) then
            a=x
          else
            b=x
          endif
          v=w
          fv=fw
          dv=dw
          w=x
          fw=fx
          dw=dx
          x=u
          fx=fu
          dx=du
        else
          if(u.lt.x) then
            a=u
          else
            b=u
          endif
          if(fu.le.fw .or. w.eq.x) then
            v=w
            fv=fw
            dv=dw
            w=u
            fw=fu
            dw=du
          else if(fu.le.fv .or. v.eq.x .or. v.eq.w) then
            v=u
            fv=fu
            dv=du
          endif
        endif
11    continue
      print *,'dbrent/Warning: exceeded maximum iterations.'
3     xmin=x
      dbrent=fx
      return
end function dbrent
!
!end module dcv_cgrad
end module dcv_2D_mod


Subroutine inian1
  Implicit Double Precision (A-H, O-Z)
  Common /para4/iftflg, ireflg, igeflg, ibstfg
  Common /ana1/ts(12)
  Save
  If (ibstfg/=0) Then
     a = cosh(6D0)
     Do i = 1, 12
        ts(i) = ts(i)*a
     End Do
  End If
  Return
End Subroutine inian1


module REGULAR_AUX
! Description:
!    Contains auxiliary procedures necessary for the integration of regularized
!    formulations.
!
! Author:
!    Davide Amato
!    Space Dynamics Group - Technical University of Madrid
!    davideamato@email.arizona.edu
!
! ==============================================================================

! MODULES
use KINDS, only: dk
use EDROMO
use KUST_STI
use STI_SCHE

! VARIABLES
implicit none

contains

function PHYSICAL_TIME(eqs,neq,x,y)
! Description:
!    Computes the value of the dimensionless physical time, given the values of
!    the state vector and of the independent variable.
!
! ==============================================================================

! VARIABLES
implicit none
integer,intent(in)   ::  eqs,neq
real(dk),intent(in)  ::  y(1:neq),x
real(dk)             ::  PHYSICAL_TIME
! Locals
integer              ::  ftime

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

select case (eqs)
    case(1,-1) ! Cowell
        PHYSICAL_TIME = x

    case(2:4)  ! EDromo
        ftime = eqs - 2
        PHYSICAL_TIME = EDROMO_TE2TIME(y,x,ftime)

    case(5:6)  ! KS
        ftime = eqs - 5
        PHYSICAL_TIME = KS_TE2TIME(y,ftime)

    case(7:8)
        ftime = eqs - 7
        PHYSICAL_TIME = STISCHE_TE2TIME(y,x,ftime)

end select

end function PHYSICAL_TIME

function CARTESIAN(eqs,neq,DU,TU,x,y,ydot)
! Description:
!    Computes the Cartesian coordinates in the inertial reference frame from
!    the state vector and independent variable. Output is dimensional.
!
! ==============================================================================

! VARIABLES
implicit none
! Arguments
integer,intent(in)            ::  eqs,neq
real(dk),intent(in)           ::  DU,TU,x,y(1:neq)
real(dk),intent(in),optional  ::  ydot(1:neq)
real(dk)                      ::  CARTESIAN(1:6)
! Locals
real(dk)    ::  R(1:3),V(1:3)

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

select case (eqs)
    case(-1)  ! Cowell, 2nd order
        CARTESIAN = [y*DU,ydot*DU*TU]

    case(1)   ! Cowell, 1st order
        CARTESIAN = [y(1:3)*DU,y(4:6)*DU*TU]

    case(2:4) ! EDromo
        call EDROMO2CART(x,y,R,V)
        CARTESIAN = [R*DU,V*DU*TU]

    case(5:6) ! KS
        call KS2CART(y,R,V)
        CARTESIAN = [R*DU,V*DU*TU]

    case(7:8) ! Stiefel-Scheifele
        call STISCHE2CART(x,y,R,V)
        CARTESIAN = [R*DU,V*DU*TU]

end select

end function CARTESIAN

end module REGULAR_AUX


!file: coord_desc_iter.f90
subroutine coord_desc_iter(prec, corr, latent, weight, & !inplace
                           observation, dims_pop, & !inputs :: data
                           lambda_ridge, lambda_glasso, & !inputs :: parameters
                           num_pop, dim_obs, num_trial) !inputs :: dimensions
    implicit none

    !inputs :: dimensions
    integer, intent(in) :: num_pop, dim_obs, num_trial

    !inputs :: data
    real(8), dimension(dim_obs, num_trial), intent(in) :: observation
    integer, dimension(num_pop), intent(in) :: dims_pop

    !inputs :: parameters
    real(8), dimension(num_pop, num_pop), intent(in) :: lambda_glasso
    real(8), dimension(num_pop), intent(in) :: lambda_ridge

    ! in/outputs
    real(8), dimension(num_pop, num_pop) :: prec, corr
    real(8), dimension(num_pop, num_trial) :: latent
    real(8), dimension(dim_obs) :: weight

!f2py intent(inplace) prec
!f2py intent(inplace) corr
!f2py intent(inplace) latent
!f2py intent(inplace) weight

    ! local variables
    integer :: i, j, k, ind_from, ind_to
    integer :: num_pop_dep, num_pop_indep

    external DGETRF
    !external coord_desc_iter_p

    ! iterate on populations
    do i = 1, num_pop
        ind_from = sum(dims_pop(:i-1)) + 1
        ind_to = sum(dims_pop(:i))

        num_pop_dep = count((lambda_glasso(i,:) >= 0) .and. &
                            ((/(k,k=1,num_pop)/) /= i))
        num_pop_indep = count((lambda_glasso(i,:) < 0) .and. &
                              ((/(k,k=1,num_pop)/) /= i))

        call coord_desc_iter_p(prec, corr, latent, weight(ind_from:ind_to), &
            observation(ind_from:ind_to,:), lambda_ridge(i), &
            pack(lambda_glasso(i,:), (lambda_glasso(i,:) >= 0) .and. &
                                     ((/(k,k=1,num_pop)/) /= i)), &
            i, pack((/(j,j=1,num_pop)/), (lambda_glasso(i,:) >= 0) .and. &
                                         ((/(k,k=1,num_pop)/) /= i)), &
            pack((/(j,j=1,num_pop)/), (lambda_glasso(i,:) < 0) .and. &
                                      ((/(k,k=1,num_pop)/) /= i)), &
            dims_pop(i), num_pop_dep, num_pop_indep, num_pop, num_trial)
    end do

end subroutine coord_desc_iter


  SUBROUTINE sinegrid

    USE basic
    USE fields
    USE constants
    USE interpolate
    !
    ! Generates a sinusoidal electric field on a grid.

    INTEGER :: k,l,tau

    rtiltgrid           = 0.
    ztiltgrid           = 0.
    es_potgrid_t        = 0.
    es_potgrid          = 0.
    dpotdrtiltgrid      = 0.
    dpotdztiltgrid      = 0.
    d2potdrdztiltgrid   = 0.
    dpotdrtiltgrid_t    = 0.
    dpotdztiltgrid_t    = 0.
    d2potdrdztiltgrid_t = 0.

    DO k = 0,numrpts - 1
      rtiltgrid(k) = Lr*k/numrpts
      DO l = 0,numzpts - 1
        ztiltgrid(l) = Lz*l/numzpts
	DO tau = 0,numtpts
	  es_potgrid_t(k,l,tau)      =       E_mag1*sin(kr*rtiltgrid(k)*sinmoder)*sin(kz*ztiltgrid(l)*sinmodez)*cos(sinmodet*tau)
          IF (sinecentdiff==.FALSE.) THEN
             dpotdrtiltgrid_t(k,l,tau)    =             E_mag1*kr*sinmoder*cos(kr*rtiltgrid(k)*sinmoder)*sin(kz*ztiltgrid(l)*sinmodez)*cos(sinmodet*tau)
             dpotdztiltgrid_t(k,l,tau)    =             E_mag1*kz*sinmodez*sin(kr*rtiltgrid(k)*sinmoder)*cos(kz*ztiltgrid(l)*sinmodez)*cos(sinmodet*tau)
             d2potdrdztiltgrid_t(k,l,tau) = E_mag1*kz*kr*sinmoder*sinmodez*cos(kr*rtiltgrid(k)*sinmoder)*cos(kz*ztiltgrid(l)*sinmodez)*cos(sinmodet*tau)
          END IF
	END DO
      END DO
    END DO

    rtiltgrid(numrpts) = rtiltgrid(0)
    ztiltgrid(numzpts) = ztiltgrid(0)

    IF (sinecentdiff==.FALSE.) THEN
       es_potgrid_t(numrpts,:,:) = es_potgrid_t(0,:,:)
       es_potgrid_t(:,numzpts,:) = es_potgrid_t(:,0,:)

       dpotdrtiltgrid_t(numrpts,:,:) = dpotdrtiltgrid_t(0,:,:)
       dpotdrtiltgrid_t(:,numzpts,:) = dpotdrtiltgrid_t(:,0,:)

       dpotdztiltgrid_t(numrpts,:,:) = dpotdztiltgrid_t(0,:,:)
       dpotdztiltgrid_t(:,numzpts,:) = dpotdztiltgrid_t(:,0,:)

       d2potdrdztiltgrid_t(numrpts,:,:) = d2potdrdztiltgrid_t(0,:,:)
       d2potdrdztiltgrid_t(:,numzpts,:) = d2potdrdztiltgrid_t(:,0,:)
    END IF

  END SUBROUTINE sinegrid


         Subroutine Model(CurSet,
     C                   NoOfParams,
     C                   NoOfDerived,
     C                   TotalDataValues,
     C                   MaxNoOfDataValues,
     C                   NoOfDataCols,
     C                   NoOfAbscissaCols,
     C                   NoOfModelVectors,
     C                   Params,
     C                   Derived,
     C                   Abscissa,
     C                   Signal)

        Implicit  None
        Integer,       Intent(In)::   CurSet
        Integer,       Intent(In)::   NoOfParams
        Integer,       Intent(In)::   NoOfDerived
        Integer,       Intent(In)::   TotalDataValues
        Integer,       Intent(In)::   MaxNoOfDataValues
        Integer,       Intent(In)::   NoOfDataCols
        Integer,       Intent(In)::   NoOfAbscissaCols
        Integer,       Intent(In)::   NoOfModelVectors
        Real (Kind=8), Intent(In)::   Params(NoOfParams)
        Real (Kind=8), Intent(InOut)::Derived(NoOfDerived)
        Real (Kind=8), Intent(In)::   Abscissa(NoOfAbscissaCols,MaxNoOfDataValues)
        Real (Kind=8), Intent(InOut)::Signal(NoOfDataCols,MaxNoOfDataValues)
        Integer        NoOfDoses
        Parameter     (NoOfDoses=4)
        Integer        N
        Parameter     (N=1)
        Real (Kind=8)  D(NoOfDoses)
        Data           D/1.0,1.0,1.0,1.0/
        Real (Kind=8)  TimeOfDose(NoOfDoses)
        Data           TimeOfDose/15.0,19.0,23.0,27.0/
        Real (Kind=8)  tHalf
        Integer        CurEntry
        Integer        CurDose
        Real (Kind=8)  EC50,TS,C,U,T,Emax,QuadAmp,LinAmp,Constant

        EC50  = Params(1)
        TS    = Params(2)
        tHalf = Params(3)
        Emax  = Params(4)
        QuadAmp = Params(7)
        LinAmp = Params(6)
        Constant = Params(5)

        Do CurEntry = 1, TotalDataValues
           C = 0D0
           Do CurDose = 1, NoOfDoses
              T = Abscissa(1,CurEntry) - TS - TimeOfDose(CurDose)
              If(T.Lt.0D0)Then
                 U = 0D0
              Else
                 U = 1D0
              EndIf
              C = C + D(CurDose)*((0.5D0)**(T/tHalf))*U
           EndDo
           Signal(1,CurEntry) = Emax*(C**N/(EC50 + C**N)) + QuadAmp*(Abscissa(1,CurEntry)**2) + LinAmp*Abscissa(1,CurEntry)
     C + Constant
        EndDo

        Derived(1)=EC50
        Derived(2)=TS
        Derived(3)=tHalf
        Derived(4)=Emax

        Return
        End


c=======================================================================
c
c     subroutine SVD
c
c     Singular value decomposition   A(n,m) =U(n,n)*S*V(m,m)'
c
c-----------------------------------------------------------------------
      SUBROUTINE svd ( m, n, A, dwork, U, VT, S, info)
c-----------------------------------------------------------------------
c
c     INPUT
c       m     : number of rows                                   integer
c       n     : number of columns                                integer
c       A     : matrix (n*m)                                      double
c
c     WORKSPACE
c       dwork : 8*min(m,n)+max(m,n)                              integer
c
c     OUTPUT
c       U     : matrix (n*n)                                      double
c       VT    : matrix (m*m)                                      double
c       S     : increased sorted singular values min(n,m)         double
c       info  : diagnostic argument                              integer
c
c------------------------------------------------------------------------

      IMPLICIT NONE
      INTEGER m, n, info
      DOUBLE PRECISION A(n,*), S(*), U(n,*), VT(m,*)
c
c     workspaces
      DOUBLE PRECISION dwork(*)
c
c     local variables
      INTEGER lda, lwork, ldu, ldvt, maxmn
c
      maxmn = MAX(n,m)
      ldu   = maxmn
      ldvt  = maxmn
      lda   = maxmn
      lwork = 9*maxmn
c
c     DGESVD computes the singular value decomposition (SVD)
c     of a real N-by-M matrix
      CALL DGESVD( 'A', 'A', n, m, A, lda, S, U, ldu, VT, ldvt,
     $             dwork(1), lwork, info )
      RETURN
      END


SUBROUTINE fmkdke(km,kp,c,ke,kd,theta)
!
! This subroutine builds up the 'coupled' stiffnesses ke and kd from
! the 'elastic' stiffness km, fluid stiffness kp and coupling matrix c.
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::km(:,:),kp(:,:),c(:,:),theta
 REAL(iwp),INTENT(OUT)::ke(:,:),kd(:,:)
 INTEGER::ndof
 REAL::one=1.0_iwp
 ndof=SIZE(km,1)
 ke(:ndof,:ndof)=theta*km
 ke(:ndof,ndof+1:)=theta*c
 ke(ndof+1:,:ndof)=theta*TRANSPOSE(c)
 ke(ndof+1:,ndof+1:)=-theta**2*kp
 kd(:ndof,:ndof)=(theta-one)*km
 kd(:ndof,ndof+1:)=(theta-one)*c
 kd(ndof+1:,:ndof)=ke(ndof+1:,:ndof)
 kd(ndof+1:,ndof+1:)=theta*(one-theta)*kp
RETURN
END SUBROUTINE fmkdke


	real*8 function stability(mm1,mm2,mm3,ein,eout,inc)

*       Three-body stability test (Mardling & Aarseth 1999)
*
        implicit real*8 (a-h,m,o-z)
        REAL*8 inc

*       Employ the semi-analytical stability criterion (MA 1999).
      Q = mm3/(mm1 + mm2)
      IF (EOUT.LT.1.0) THEN
          XFAC = (1.0 + Q)*(1.0 + EOUT)/SQRT(1.0 - EOUT)
      ELSE
          XFAC = 40.0*(1.0 + Q)
      END IF
      PCRIT = 2.8*XFAC**0.4
*
*       Include the inclination fudge factor.
      YFAC = 1.0 - 0.3*INC/3.1415
      PCRIT = YFAC*PCRIT
*
        stability=PCRIT

	end


	SUBROUTINE PLANCK(TEMP,Q,QP)
C***********************************************************************
C	SUBROUTINE PLANCK CALCULATES THE PLANCK MEAN EFFICIENCIES
C	USING A REDUCED FORM OF THE PLANCK BB INTENSITY DISTRIBUTION
C	(SEE MENGUC & VISKANTA, COMBUST SCI TECH, 44, 143-159, 1985);
C	INTEGRATION IS PERFORMED USING SIMPSON'S COMPOSITE ALGORITHM
C***********************************************************************
	DIMENSION Q(50)
	DATA PI/3.1415927/,C2/14400.0/
C***********************************************************************
C	USE SMALL AND LARGE ZETA LIMITS TO APPROXIMATE 0-INF. INTEGRAL,
C	0.01-50.0 SEEMS TO APPROXIMATE THIS WELL WITHOUT RUNNING INTO
C	LARGE NUMBER PROBLEMS WITH EXPONENTIALS - PROPERTY RANGES ARE
C	ASSUMED CONSTANT BEYOND CALCULATED LIMITS TO ALLOW THIS;
C	C2DT IS 2ND RADIATION CONSTANT DIVIDED BY TEMPERATURE - THIS IS
C	USED TO EXTRACT CURRENT WAVELENGTH FOR DIFFERENT TEMPERATURES
C	(E.G., T=1000: C2DT=14.40, T=1500: C2DT=9.60, FOR SI UNITS)
C***********************************************************************
	A = 0.01
	B = 50.0
	C2DT = C2 / TEMP
	H = 0.01
	M = NINT((B - A) / (2. * H))
	FA = Q(27) * A**3 / (EXP(A) - 1.)
	FB = Q(1) * B**3 / (EXP(B) - 1.)
	XI0 = FA + FB
	XI1 = 0.0
	XI2 = 0.0
	DO 100 I=1,2*M-1
	  Z = A + FLOAT(I)*H
	  WL = C2DT / Z
	  IF (WL.GE.12.75) THEN
	    IW = 27
	  ELSE IF (WL.LT.12.75 .AND. WL.GE.12.25) THEN
	    IW = 26
	  ELSE IF (WL.LT.12.25 .AND. WL.GE.11.75) THEN
	    IW = 25
	  ELSE IF (WL.LT.11.75 .AND. WL.GE.11.25) THEN
	    IW = 24
	  ELSE IF (WL.LT.11.25 .AND. WL.GE.10.75) THEN
	    IW = 23
	  ELSE IF (WL.LT.10.75 .AND. WL.GE.10.25) THEN
	    IW = 22
	  ELSE IF (WL.LT.10.25 .AND. WL.GE.9.75) THEN
	    IW = 21
	  ELSE IF (WL.LT.9.75 .AND. WL.GE.9.25) THEN
	    IW = 20
	  ELSE IF (WL.LT.9.25 .AND. WL.GE.8.75) THEN
	    IW = 19
	  ELSE IF (WL.LT.8.75 .AND. WL.GE.8.25) THEN
	    IW = 18
	  ELSE IF (WL.LT.8.25 .AND. WL.GE.7.75) THEN
	    IW = 17
	  ELSE IF (WL.LT.7.75 .AND. WL.GE.7.25) THEN
	    IW = 16
	  ELSE IF (WL.LT.7.25 .AND. WL.GE.6.75) THEN
	    IW = 15
	  ELSE IF (WL.LT.6.75 .AND. WL.GE.6.25) THEN
	    IW = 14
	  ELSE IF (WL.LT.6.25 .AND. WL.GE.5.75) THEN
	    IW = 13
	  ELSE IF (WL.LT.5.75 .AND. WL.GE.5.25) THEN
	    IW = 12
	  ELSE IF (WL.LT.5.25 .AND. WL.GE.4.75) THEN
	    IW = 11
	  ELSE IF (WL.LT.4.75 .AND. WL.GE.4.25) THEN
	    IW = 10
	  ELSE IF (WL.LT.4.25 .AND. WL.GE.3.75) THEN
	    IW = 9
	  ELSE IF (WL.LT.3.75 .AND. WL.GE.3.25) THEN
	    IW = 8
	  ELSE IF (WL.LT.3.25 .AND. WL.GE.2.75) THEN
	    IW = 7
	  ELSE IF (WL.LT.2.75 .AND. WL.GE.2.25) THEN
	    IW = 6
	  ELSE IF (WL.LT.2.25 .AND. WL.GE.1.75) THEN
	    IW = 5
	  ELSE IF (WL.LT.1.75 .AND. WL.GE.1.25) THEN
	    IW = 4
	  ELSE IF (WL.LT.1.25 .AND. WL.GE.0.75) THEN
	    IW = 3
	  ELSE IF (WL.LT.0.75 .AND. WL.GT.0.25) THEN
	    IW = 2
	  ELSE IF (WL.LE.0.25) THEN
	    IW = 1
	  END IF
	  FX = Q(IW) * Z**3 / (EXP(Z) - 1.)
	  IF (MOD(I,2).EQ.0) THEN
	    XI2 = XI2 + FX
	  ELSE
	    XI1 = XI1 + FX
	  END IF
100	CONTINUE
	QI = H * (XI0 + 2.*XI2 + 4.*XI1) / 3.0
	QP = (15. / PI**4) * QI
C
	RETURN
	END


! { dg-do compile }
! { dg-options "-Wconversion" }
!
! PR fortran/54234
!
!
module fft_mod
  implicit none
  integer, parameter :: dp=kind(0.0d0)
contains
  subroutine test
    integer :: x
    x = int (abs (cmplx(2.3,0.1)))
    x = int (abs (cmplx(2.3_dp,0.1))) ! { dg-warning "Conversion from REAL.8. to default-kind COMPLEX.4. at .1. might lose precision, consider using the KIND argument" }
    x = int (abs (cmplx(2.3,0.1_dp))) ! { dg-warning "Conversion from REAL.8. to default-kind COMPLEX.4. at .1. might lose precision, consider using the KIND argument" }
    x = int (abs (cmplx(2.3_dp,0.1_dp))) ! { dg-warning "Conversion from REAL.8. to default-kind COMPLEX.4. at .1. might lose precision, consider using the KIND argument" }
  end subroutine test
end module fft_mod


C
C
      SUBROUTINE ANDEBY(THETA,TK,D,D2,DS)
C
C***********************************************************************
C
C     ANEOS PACKAGE         EVALUATES DEBYE FUNCTIONS
C
C************************************** 8/87 version slt ***************
C
C     INPUTS:  TK    = Temperature of evaluation
C              THETA = Debye temperature
C
C     OUTPUTS: D  =  Debye integral, D(X)
C              D2 =  function ALOG(1-EXP(-X))
C              DS =  function 3*(D(X)-X/(EXP(X)-1))
C              where X = THETA/TK
C
C***********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON /FILEOS/ KLST, KINP
      SAVE /FILEOS/
      PARAMETER (ZERO=0.D0)
      PARAMETER (ONE=1.D0)
      PARAMETER (THREE=3.D0)
      PARAMETER (SIX=6.D0)
      PARAMETER (QCG1=0.1D0)
      PARAMETER (QCG2=0.375D0)
      PARAMETER (QCG3=0.05D0)
      PARAMETER (QCG4=5.952380953D-4)
      PARAMETER (QCG5=7.25D0)
      PARAMETER (QCG6=0.0946173D0)
      PARAMETER (QCG7=4.432582D0)
      PARAMETER (QCG8=85.07724D0)
      PARAMETER (QCG9=800.6087D0)
      PARAMETER (QCG10=3953.632D0)
      PARAMETER (QCG11=15.121491D0)
      PARAMETER (QCG12=143.155337D0)
      PARAMETER (QCG13=682.0012D0)
      PARAMETER (QCG14=3953.632D0)
      PARAMETER (QCG15=25.D0)
      PARAMETER (QCG16=6.493939402D0)
C
      X=THETA/TK
      EXX=EXP(-X)
      IF(X.GT.QCG1) GO TO 5
        X2=X*X
        D=ONE-QCG2*X+X2*(QCG3-QCG4*X2)
        GO TO 25
    5 IF(X-QCG5) 10,10,13
   10 D=((((QCG6*X-QCG7)*X+QCG8)*X-QCG9)*X+QCG10)
     1 /((((X+QCG11)*X+QCG12)*X+QCG13)*X+QCG14)
      GO TO 25
   13 N=QCG15/X
      D=ZERO
      IF (N.LE.0) GO TO 20
      D2=ONE
        DO 15 I=1,N
        DS=I
        D2=D2*EXX
        X3=DS*X
   15   D=D+D2*(SIX+X3*(SIX+X3*(THREE+X3)))/(DS**4)
   20 D=THREE*(QCG16-D)/(X**3)
   25 D2=LOG(ONE-EXX)
      DS=THREE*(D-X*(EXX/(ONE-EXX)))
      RETURN
      END


      SUBROUTINE MC03NY( NBLCKS, NRA, NCA, A, LDA, E, LDE, IMUK, INUK,
     $                   VEPS, LDVEPS, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To determine a minimal basis of the right nullspace of the
C     subpencil s*E(eps)-A(eps) using the method given in [1] (see
C     Eqs.(4.6.8), (4.6.9)).
C     This pencil only contains Kronecker column indices, and it must be
C     in staircase form as supplied by SLICOT Library Routine MB04VD.
C     The basis vectors are represented by matrix V(s) having the form
C
C                | V11(s) V12(s) V13(s)   . .   V1n(s) |
C                |        V22(s) V23(s)         V2n(s) |
C                |               V33(s)           .    |
C         V(s) = |                  .             .    |
C                |                      .         .    |
C                |                          .     .    |
C                |                              Vnn(s) |
C
C     where n is the number of full row rank blocks in matrix A(eps) and
C
C                                               k               j-i
C         Vij(s) = Vij,0 + Vij,1*s +...+ Vij,k*s +...+ Vij,j-i*s   . (1)
C
C     In other words, Vij,k is the coefficient corresponding to degree k
C     in the matrix polynomial Vij(s).
C     Vij,k has dimensions mu(i)-by-(mu(j)-nu(j)).
C     The coefficients Vij,k are stored in the matrix VEPS as follows
C     (for the case n = 3):
C
C         sizes      m1-n1    m2-n2   m2-n2    m3-n3   m3-n3   m3-n3
C
C             m1 { | V11,0 || V12,0 | V12,1 || V13,0 | V13,1 | V13,2 ||
C                  |       ||       |       ||       |       |       ||
C      VEPS = m2 { |       || V22,0 |       || V23,0 | V23,1 |       ||
C                  |       ||       |       ||       |       |       ||
C             m3 { |       ||       |       || V33,0 |       |       ||
C
C     where mi = mu(i), ni = nu(i).
C     Matrix VEPS has dimensions nrv-by-ncv where
C       nrv = Sum(i=1,...,n) mu(i)
C       ncv = Sum(i=1,...,n) i*(mu(i)-nu(i))
C
C     ==================================================================
C     REMARK: This routine is intended to be called only from the SLICOT
C             routine MC03ND.
C     ==================================================================
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     NBLCKS  (input) INTEGER
C             Number of full row rank blocks in subpencil
C             s*E(eps)-A(eps) that contains all Kronecker column indices
C             of s*E-A.  NBLCKS >= 0.
C
C     NRA     (input) INTEGER
C             Number of rows of the subpencil s*E(eps)-A(eps) in s*E-A.
C             NRA = nu(1) + nu(2) + ... + nu(NBLCKS).  NRA >= 0.
C
C     NCA     (input) INTEGER
C             Number of columns of the subpencil s*E(eps)-A(eps) in
C             s*E-A.
C             NCA = mu(1) + mu(2) + ... + mu(NBLCKS).  NCA >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,NCA)
C     E       (input/output) DOUBLE PRECISION array, dimension (LDE,NCA)
C             On entry, the leading NRA-by-NCA part of these arrays must
C             contain the matrices A and E, where s*E-A is the
C             transformed pencil s*E0-A0 which is the pencil associated
C             with P(s) as described in [1] Section 4.6. The pencil
C             s*E-A is assumed to be in generalized Schur form.
C             On exit, these arrays contain no useful information.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,NRA).
C
C     LDE     INTEGER
C             The leading dimension of array E.  LDE >= MAX(1,NRA).
C
C     IMUK    (input) INTEGER array, dimension (NBLCKS)
C             This array must contain the column dimensions mu(k) of the
C             full column rank blocks in the subpencil s*E(eps)-A(eps)
C             of s*E-A. The content of IMUK is modified by the routine
C             but restored on exit.
C
C     INUK    (input) INTEGER array, dimension (NBLCKS)
C             This array must contain the row dimensions nu(k) of the
C             full row rank blocks in the subpencil s*E(eps)-A(eps) of
C             s*E-A.
C
C     VEPS    (output) DOUBLE PRECISION array, dimension (LDVEPS,ncv)
C             Let nrv = Sum(i=1,...,NBLCKS) mu(i) = NCA,
C                 ncv = Sum(i=1,...,NBLCKS) i*(mu(i)-nu(i)).
C             The leading nrv-by-ncv part of this array contains the
C             column vectors of a minimal polynomial basis for the right
C             nullspace of the subpencil s*E(eps)-A(eps). (See [1]
C             Section 4.6.4.) An upper bound for ncv is (NRA+1)*NCA.
C
C     LDVEPS  INTEGER
C             The leading dimension of array VEPS.
C             LDVEPS >= MAX(1,NCA).
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             > 0:  if INFO = k, the k-th diagonal block of A had not a
C                   full row rank.
C
C     REFERENCES
C
C     [1] Th.G.J. Beelen, New Algorithms for Computing the Kronecker
C         structure of a Pencil with Applications to Systems and
C         Control Theory.
C         Ph.D.Thesis, Eindhoven University of Technology, 1987.
C
C     NUMERICAL ASPECTS
C
C     None.
C
C     CONTRIBUTORS
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997.
C     Supersedes Release 2.0 routine MC03BY by Th.G.J. Beelen,
C     A.J. Geurts, and G.J.H.H. van den Hurk.
C
C     REVISIONS
C
C     Dec. 1997.
C
C     KEYWORDS
C
C     Elementary polynomial operations, Kronecker form, polynomial
C     matrix, polynomial operations, staircase form.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      INTEGER           INFO, LDA, LDE, LDVEPS, NBLCKS, NCA, NRA
C     .. Array Arguments ..
      INTEGER           IMUK(*), INUK(*)
      DOUBLE PRECISION  A(LDA,*), E(LDE,*), VEPS(LDVEPS,*)
C     .. Local Scalars ..
      INTEGER           AC1, AC2, AR1, ARI, ARK, DIF, EC1, ER1, I, J, K,
     $                  MUI, NCV, NRV, NUI, SMUI, SMUI1, VC1, VC2, VR1,
     $                  VR2, WC1, WR1
C     .. Local Arrays ..
      DOUBLE PRECISION  DUMMY(1)
C     .. External Subroutines ..
      EXTERNAL          DCOPY, DGEMM, DLASET, DSCAL, DTRTRS, XERBLA
C     .. Executable Statements ..
C
      INFO = 0
      IF( NBLCKS.LT.0 ) THEN
         INFO = -1
      ELSE IF( NRA.LT.0 ) THEN
         INFO = -2
      ELSE IF( NCA.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, NRA ) ) THEN
         INFO = -5
      ELSE IF( LDE.LT.MAX( 1, NRA ) ) THEN
         INFO = -7
      ELSE IF( LDVEPS.LT.MAX( 1, NCA ) ) THEN
         INFO = -11
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'MC03NY', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( NBLCKS.EQ.0 .OR. NRA.EQ.0 .OR. NCA.EQ.0 )
     $   RETURN
C
C     Computation of the nonzero parts of W1 and W2:
C
C          | AH11 AH12 ... AH1n |       | EH11 EH12 ... EH1n |
C          |      AH22     AH2n |       |      EH22     EH2n |
C     W1 = |         .       .  |, W2 = |         .       .  |
C          |           .     .  |       |           .     .  |
C          |               AHnn |       |               EHnn |
C
C     with AHij = -pinv(Aii) * Aij, EHij = pinv(Aii) * Eij and EHii = 0,
C     AHij and EHij have dimensions mu(i)-by-mu(j), Aii = [ Oi | Ri ],
C     and
C       Ri is a regular nu(i)-by-nu(i) upper triangular matrix;
C       Oi is a not necessarily square null matrix.
C     Note that the first mu(i)-nu(i) rows in AHij and EHij are zero.
C     For memory savings, the nonzero parts of W1 and W2 are constructed
C     over A and E, respectively.
C
C     (AR1,AC1) denotes the position of the first element of the
C     submatrix Ri in matrix Aii.
C     EC1 is the index of the first column of Ai,i+1/Ei,i+1.
C
      EC1 = 1
      AR1 = 1
C
      DO 40 I = 1, NBLCKS - 1
         NUI = INUK(I)
         IF ( NUI.EQ.0 ) GO TO 60
         MUI = IMUK(I)
         EC1 = EC1 + MUI
         AC1 = EC1 - NUI
         CALL DTRTRS( 'Upper', 'No transpose', 'Non-unit', NUI,
     $                NCA-EC1+1, A(AR1,AC1), LDA, E(AR1,EC1), LDE,
     $                INFO )
         IF ( INFO.GT.0 ) THEN
            INFO = I
            RETURN
         END IF
C
         DO 20 J = 1, NUI
            CALL DSCAL( J, -ONE, A(AR1,AC1+J-1), 1 )
   20    CONTINUE
C
         CALL DTRTRS( 'Upper', 'No transpose', 'Non-unit', NUI,
     $                NCA-EC1+1, A(AR1,AC1), LDA, A(AR1,EC1), LDA,
     $                INFO )
         AR1 = AR1 + NUI
   40 CONTINUE
C
   60 CONTINUE
C
C     The contents of the array IMUK is changed for temporary use in
C     this routine as follows:
C
C        IMUK(i) = Sum(j=1,...,i) mu(j).
C
C     On return, the original contents of IMUK is restored.
C     In the same loop the actual number of columns of VEPS is computed.
C     The number of rows of VEPS is NCA.
C
C        NRV = Sum(i=1,...,NBLCKS) mu(i) = NCA,
C        NCV = Sum(i=1,...,NBLCKS) i*(mu(i)-nu(i)).
C
      SMUI = 0
      NCV = 0
C
      DO 80 I = 1, NBLCKS
         MUI = IMUK(I)
         SMUI = SMUI + MUI
         IMUK(I) = SMUI
         NCV = NCV + I*( MUI - INUK(I) )
   80 CONTINUE
C
      NRV = NCA
C
C     Computation of the matrix VEPS.
C
C     Initialisation of VEPS to zero.
C
      CALL DLASET( 'Full', NRV, NCV, ZERO, ZERO, VEPS, LDVEPS )
C                                                           | I |
C     Set Vii,0 = Kii in VEPS , i=1,...,NBLCKS, where Kii = |---|
C                                                           | O |
C     and I is an identity matrix of size mu(i)-nu(i),
C         O is a null matrix, dimensions nu(i)-by-(mu(i)-nu(i)).
C
C     WR1 := Sum(j=1,...,i-1) mu(j) + 1
C            is the index of the first row in Vii,0 in VEPS.
C     WC1 := Sum(j=1,...,i-1) j*(mu(j)-nu(j)) + 1
C            is the index of the first column in Vii,0 in VEPS.
C
      DUMMY(1) = ONE
      NUI = IMUK(1) - INUK(1)
      CALL DCOPY( NUI, DUMMY, 0, VEPS, LDVEPS+1 )
      WR1 = IMUK(1) + 1
      WC1 = NUI + 1
C
      DO 100 I = 2, NBLCKS
         NUI = IMUK(I) - IMUK(I-1) - INUK(I)
         CALL DCOPY( NUI, DUMMY, 0, VEPS(WR1,WC1), LDVEPS+1 )
         WR1 = IMUK(I) + 1
         WC1 = WC1 + I*NUI
  100 CONTINUE
C
C     Determination of the remaining nontrivial matrices in Vij,k
C     block column by block column with decreasing block row index.
C
C     The computation starts with the second block column since V11,0
C     has already been determined.
C     The coefficients Vij,k satisfy the recurrence relation:
C
C        Vij,k = Sum(r=i+1,...,j-k)   AHir*Vrj,k +
C              + Sum(r=i+1,...,j-k+1) EHir*Vrj,k-1,   i + k < j,
C
C              = EHi,i+1 * Vi+1,j,k-1                 i + k = j.
C
C     This recurrence relation can be derived from [1], (4.6.8)
C     and formula (1) in Section PURPOSE.
C
      VC1 = IMUK(1) - INUK(1) + 1
      ARI = 1
C
      DO 180 J = 2, NBLCKS
         DIF = IMUK(J) - IMUK(J-1) - INUK(J)
         ARI = ARI + INUK(J-1)
         ARK = ARI
C
C        Computation of the matrices Vij,k where i + k < j.
C        Each matrix Vij,k has dimension mu(i)-by-(mu(j) - nu(j)).
C
         DO 160 K = 0, J - 2
C
C           VC1, VC2 are the first and last column index of Vij,k.
C
            VC2 = VC1 + DIF - 1
            AC2 = IMUK(J-K)
            AR1 = ARK
            ARK = ARK - INUK(J-K-1)
C
            DO 120 I = J - K - 1, 1, -1
C
C              Compute the first part of Vij,k in decreasing order:
C              Vij,k := Vij,k + Sum(r=i+1,..,j-k) AHir*Vrj,k.
C              The non-zero parts of AHir are stored in
C              A(AR1:AR1+nu(i)-1,AC1:AC2) and Vrj,k are stored in
C              VEPS(AC1:AC2,VC1:VC2).
C              The non-zero part of the result is stored in
C              VEPS(VR1:VR2,VC1:VC2).
C
               VR2 = IMUK(I)
               AC1 = VR2 + 1
               VR1 = AC1 - INUK(I)
               AR1 = AR1 - INUK(I)
               CALL DGEMM( 'No transpose', 'No transpose', INUK(I),
     $                     DIF, AC2-VR2, ONE, A(AR1,AC1), LDA,
     $                     VEPS(AC1,VC1), LDVEPS, ONE, VEPS(VR1,VC1),
     $                     LDVEPS )
  120       CONTINUE
C
            ER1 = 1
C
            DO 140 I = 1, J - K - 1
C
C              Compute the second part of Vij,k+1 in normal order:
C              Vij,k+1 := Sum(r=i+1,..,j-k) EHir*Vrj,k.
C              The non-zero parts of EHir are stored in
C              E(ER1:ER1+nu(i)-1,EC1:AC2) and Vrj,k are stored in
C              VEPS(EC1:AC2,VC1:VC2).
C              The non-zero part of the result is stored in
C              VEPS(VR1:VR2,VC2+1:VC2+DIF), where
C              DIF = VC2 - VC1 + 1 = mu(j) - nu(j).
C              This code portion also computes Vij,k+1 for i + k = j.
C
               VR2 = IMUK(I)
               EC1 = VR2 + 1
               VR1 = EC1 - INUK(I)
               CALL DGEMM( 'No transpose', 'No transpose', INUK(I),
     $                     DIF, AC2-VR2, ONE, E(ER1,EC1), LDE,
     $                     VEPS(EC1,VC1), LDVEPS, ZERO, VEPS(VR1,VC2+1),
     $                     LDVEPS )
               ER1 = ER1 + INUK(I)
  140       CONTINUE
C
            VC1 = VC2 + 1
  160    CONTINUE
C
         VC1 = VC1 + DIF
  180 CONTINUE
C
C     Restore original contents of the array IMUK.
C
C     Since, at the moment:
C       IMUK(i) = Sum(j=1,...,i) mu(j),   (i=1,...,NBLCKS),
C     the original values are:
C       mu(i) = IMUK(i) - IMUK(i-1)  with IMUK(0 ) = 0.
C
      SMUI1 = 0
C
      DO 200 I = 1, NBLCKS
         SMUI = IMUK(I)
         IMUK(I) = SMUI - SMUI1
         SMUI1 = SMUI
  200 CONTINUE
C
      RETURN
C *** Last line of MC03NY ***
      END


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Given (lat,lon) of a point on target and GETSPICE95 navigation data,
C caluclate phase, incidence, and emission angles.
C
      SUBROUTINE LIGHTING(BUF,LAT,LON,phase,incidence,emission)
      IMPLICIT NONE
      REAL*8 BUF(100)		!GETSPICE95 buffer (input)
      REAL*8 LAT,LON		!Point where angles are calculated
      REAL*8 PHASE,INCIDENCE,EMISSION	!Output lighting angles

      REAL*8 RA,RC		!Target radii (km)

      REAL*8 SUNRANGE		!Distance from Sun to target center (km)
      REAL*8 SUNLAT,SUNLON	!Sun lat,lon (radians)

      REAL*8 SCRANGE		!Distance from S/C to target center (km)
      REAL*8 SCLAT,SCLON	!Spacecraft lat,lon (radians)

      REAL*8 VSC(3),VSUN(3),V(3),N(3),S(3),C(3),MAGNITUDE,GCR,D
      REAL*8 RLAT,RLON

      REAL*8 PI,RTD,DTR

      PI = 3.141592653589D0
      RTD = 180.D0/PI
      DTR = PI/180.D0

      RA = BUF(13)
      RC = BUF(15)
      SUNRANGE = BUF(25)
      SUNLAT = BUF(28)*DTR
      SUNLON = (360.D0 - BUF(29))*DTR!Convert to East longitude
      CALL LATREC(SUNRANGE,SUNLON,SUNLAT,vsun)!Vector from center to Sun
C     ....Spacecraft position vector
      SCRANGE = BUF(27)
      SCLAT = BUF(30)*DTR
      SCLON = (360.D0 - BUF(31))*DTR!Convert to East longitude
C     ....Vector from center to S/C
      CALL LATREC(SCRANGE,SCLON,SCLAT,vsc)
C     ....Compute geocentric radius
      RLAT = LAT*DTR
      RLON = (360.D0 - LON)*DTR
      GCR = RA*RC/DSQRT((RC*DCOS(RLAT))**2 + (RA*DSIN(RLAT))**2)
C     ....Vector from center of target to surface pt
      CALL LATREC(GCR,RLON,RLAT,v)
C     ....Compute unit normal N at surface point
      N(1) = V(1)*(RC/RA)**2
      N(2) = V(2)*(RC/RA)**2
      N(3) = V(3)
      CALL UNORM(N,n,magnitude)
C     ....Compute unit vector from surface point to Sun
      S(1) = VSUN(1) - V(1)
      S(2) = VSUN(2) - V(2)
      S(3) = VSUN(3) - V(3)
      CALL UNORM(S,s,magnitude)
C     ....Compute unit vector from surface point to spacecraft
      C(1) = VSC(1) - V(1)
      C(2) = VSC(2) - V(2)
      C(3) = VSC(3) - V(3)
      CALL UNORM(C,c,magnitude)
C     ....phase angle = ARCCOS(S o C)
      D = S(1)*C(1) + S(2)*C(2) + S(3)*C(3)
      IF (D.GT.1.D0) D=1.D0
      IF (D.LT.-1.D0) D=-1.D0
      PHASE = DACOS(D)*RTD
C     ....incidence angle = ARCCOS(N o S)
      D = N(1)*S(1)+N(2)*S(2)+N(3)*S(3)
      IF (D.GT.1.D0) D=1.D0
      IF (D.LT.-1.D0) D=-1.D0
      INCIDENCE = DACOS(D)*RTD
C     ....emission angle = ARCCOS(N o C)
      D = N(1)*C(1)+N(2)*C(2)+N(3)*C(3)
      IF (D.GT.1.D0) D=1.D0
      IF (D.LT.-1.D0) D=-1.D0
      EMISSION = DACOS(D)*RTD
      RETURN
      END


      subroutine yzktec (f,af,g,ag,dr,ap,h,k,nd,np,idim, dyzk)
c calculation of yk(r)=zk(r)+ r**(k+1) * integral from r to
c   infinity of  f(u) * u**(-k-1)
c zk(r) = r**(-k) * integral from 0 to r of f(u) * u**k

c at the origin f(r)=sum from i=1 to nd of af(i)*r**(ap+i-1)
c dr tabulation points   h exponential step
c np number of tabulation points for f
c idim dimension of the blocks f,g and dr

c at the origin yk=cte*r**(k+1)-developement limit
c the constant for yk lies in ap
c output functions yk and zk lie in f and g, and their
c development coefficients at the origin in af and ag.

c integration from point to point by a 4 points method.
c integral from r to r+h = h*(-f(r-h)+13*f(r)+13*f(r+h)-f(r+h+h))/24

      implicit double precision (a-h,o-z)
      include '../HEADERS/dim.h'
      complex*16 f,af,g,ag,ap, dyzk
      dimension f(nrptx),af(10),g(nrptx),ag(10),dr(nrptx)

c    initialisation and development coefficients of yk
      np= min(np,idim-1)
      f(np+1)=0.0d0
      b = dble(ap)
      ap=0.0d 00
      g(1)=0.0d 00
      do i=1,nd
         b=b+1.0d 00
         ag(i)=af(i)/(b+k)
         if (af(i).ne.0.0d 00) then
            c=dr(1)**b
            g(1)=g(1)+ag(i)*c
c         for irregular solution b-k-1 can become zero
            if (abs(b-k-1) .le. 0.00001) then
               af(i) = 0.0
               b = b - 1.0d0
            else
               af(i)=(k+k+1)*ag(i)/(b-k-1)
            endif
            ap=ap+af(i)*c
         endif
      enddo
      do i=1,np
         f(i)=f(i)*dr(i)
      enddo

c     calcualation of zk
      hk=h*k
      e = exp(-h)
      ehk = e**k

      if (k.ne.0)then
       b1 = (ehk-1.0d0 +hk) / (hk*k)
      else
       b1=h/2.0
      endif

      b0 = h-(1.0+hk)*b1
      do i=1,np
         g(i+1)=g(i)*ehk+b0*f(i)+f(i+1)*b1
      enddo
c     calculation of yk
      f(np+1)=g(np+1) + dyzk
      ehk=ehk*e
      i=k+k+1
      hk=hk+h
      b1 = i*(ehk-1.0d0 +hk) / (hk*(k+1))
      b0 = i*h-(1.0+hk)*b1
      do i=np,1,-1
         f(i) = f(i+1)*ehk+b0*g(i+1)+b1*g(i)
      enddo

      ap=(ap+f(1))/(dr(1)**(k+1))
      return
      end


      subroutine runY_000000(k,l,Xtwiddle,Gtwiddle,Shat6zzzz,N0)
      implicit none
C---  Expression for D0000 obtained from 5.50, following the comment after
C     5.50 on how to add adding additional "00" pairs
C---  Calculates D0000
C---  Small terms of order Xtwiddle(0,k)*D00i,Xtwiddle(0,0)*D00ii
C---  Denominator Gtwiddle(k,l)
      include 'pvDnames.f'
      include 'pvDv.f'
      include 'Darraydef.f'
      include 'Darrays.f'
      integer ep,N0,k,l,np
      parameter(np=3)
      double precision Xtwiddle(0:np,0:np),Gtwiddle(np,np)
      double complex Shat6zzzz(np,z1max,-2:0)

      do ep=-2,0
         Dv(dd000000+N0,ep) =
     . -(-(Gtwiddle(k,1)*Shat6zzzz(1,l,ep)
     .    +Gtwiddle(k,2)*Shat6zzzz(2,l,ep)
     .    +Gtwiddle(k,3)*Shat6zzzz(3,l,ep)
     .    +Xtwiddle(k,0)*Dv(dzzzzi(l)+N0,ep)
     .    -Xtwiddle(0,0)*Dv(dzzzzii(z2(k,l))+N0,ep)
     .        ))/(2d0*Gtwiddle(k,l))

      enddo

      return
      end


*DECK R9CHU
      FUNCTION R9CHU (A, B, Z)
C***BEGIN PROLOGUE  R9CHU
C***SUBSIDIARY
C***PURPOSE  Evaluate for large Z  Z**A * U(A,B,Z) where U is the
C            logarithmic confluent hypergeometric function.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C11
C***TYPE      SINGLE PRECISION (R9CHU-S, D9CHU-D)
C***KEYWORDS  FNLIB, LOGARITHMIC CONFLUENT HYPERGEOMETRIC FUNCTION,
C             SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C Evaluate for large Z  Z**A * U(A,B,Z)  where U is the logarithmic
C confluent hypergeometric function.  A rational approximation due to Y.
C L. Luke is used.  When U is not in the asymptotic region, i.e., when A
C or B is large compared with Z, considerable significance loss occurs.
C A warning is provided when the computed result is less than half
C precision.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770801  DATE WRITTEN
C   890206  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900720  Routine changed from user-callable to subsidiary.  (WRB)
C***END PROLOGUE  R9CHU
      DIMENSION AA(4), BB(4)
      LOGICAL FIRST
      SAVE EPS, SQEPS, FIRST
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  R9CHU
      IF (FIRST) THEN
         EPS = 4.0*R1MACH(4)
         SQEPS = SQRT (R1MACH(4))
      ENDIF
      FIRST = .FALSE.
C
      BP = 1.0 + A - B
      AB = A*BP
      CT2 = 2.0*(Z-AB)
      SAB = A + BP
C
      BB(1) = 1.0
      AA(1) = 1.0
C
      CT3 = SAB + 1.0 + AB
      BB(2) = 1.0 + 2.0*Z/CT3
      AA(2) = 1.0 + CT2/CT3
C
      ANBN = CT3 + SAB + 3.0
      CT1 = 1.0 + 2.0*Z/ANBN
      BB(3) = 1.0 + 6.0*CT1*Z/CT3
      AA(3) = 1.0 + 6.0*AB/ANBN + 3.0*CT1*CT2/CT3
C
      DO 30 I=4,300
        X2I1 = 2*I - 3
        CT1 = X2I1/(X2I1-2.0)
        ANBN = ANBN + X2I1 + SAB
        CT2 = (X2I1 - 1.0) / ANBN
        C2 = X2I1*CT2 - 1.0
        D1Z = X2I1*2.0*Z/ANBN
C
        CT3 = SAB*CT2
        G1 = D1Z + CT1*(C2+CT3)
        G2 = D1Z - C2
        G3 = CT1*(1.0 - CT3 - 2.0*CT2)
C
        BB(4) = G1*BB(3) + G2*BB(2) + G3*BB(1)
        AA(4) = G1*AA(3) + G2*AA(2) + G3*AA(1)
        IF (ABS(AA(4)*BB(1)-AA(1)*BB(4)).LT.EPS*ABS(BB(4)*BB(1)))
     1    GO TO 40
C
C IF OVERFLOWS OR UNDERFLOWS PROVE TO BE A PROBLEM, THE STATEMENTS
C BELOW COULD BE ALTERED TO INCORPORATE A DYNAMICALLY ADJUSTED SCALE
C FACTOR.
C
        DO 20 J=1,3
          BB(J) = BB(J+1)
          AA(J) = AA(J+1)
 20     CONTINUE
 30   CONTINUE
      CALL XERMSG ('SLATEC', 'R9CHU', 'NO CONVERGENCE IN 300 TERMS', 1,
     +   2)
C
 40   R9CHU = AA(4)/BB(4)
C
      IF (R9CHU .LT. SQEPS .OR. R9CHU .GT. 1.0/SQEPS) CALL XERMSG
     +   ('SLATEC', 'R9CHU', 'ANSWER LESS THAN HALF PRECISION', 2, 1)
C
      RETURN
      END


      SUBROUTINE EPSVOIGT(DT,ALP,BET,SIG,GAM,FUNC,DFDX,DFDA,DFDB,
     1  DFDS,DFDG)

!PURPOSE: Compute function & derivatives exponential X pseudovoigt
!P.Tompson, D.E. Cox & J.B. Hastings (1987). J. Appl. Cryst.,20,79-83

      INCLUDE       '../INCLDS/COPYRIGT.FOR'

!PSEUDOCODE:

!CALLING ARGUMENTS:

      REAL*4        DT                  !Delta-TOF from center
      REAL*4        ALP                 !Exponential rise
      REAL*4        BET                 !Exponential decay
      REAL*4        SIG                 !Gaussian variance
      REAL*4        GAM                 !Lorentzian FWHM
      REAL*4        FUNC                !Value of pseudo-Voigt at DX
      REAL*4        DFDX                !dF/dta
      REAL*4        DFDA                !dF/da
      REAL*4        DFDB                !dF/db
      REAL*4        DFDS                !dF/ds
      REAL*4        DFDG                !dF/dg

!INCLUDE STATEMENTS:

!LOCAL VARIABLES:

      REAL*4        COFG(6),COFL(6)     !Linear combination coeffs
      REAL*4        ACOFG(7),ACOFL(7)
      REAL*4        GNORM               !Gaussian Normalization constant
      REAL*4        COFT(6),COFN(3)
      REAL*4        NORM                !Normalization constant
      REAL*4        RXA,IXA,RXB,IXB     !Exp-integral arguements
      REAL*4        RFA,IFA,RFB,IFB     !Exp-integral results

!SUBROUTINES CALLED:

!FUNCTION DEFINITIONS:

!DATA STATEMENTS:

      DATA STOFW/2.35482005/            !2*SQRT(2LN2)
      DATA SQ2PI/2.506628275/            !SQRT(2PI)
      DATA PI/3.141592654/            !PI
      DATA COFT/1.0,2.69269,2.42843,4.47163,0.07842,1.0/
      DATA COFN/1.36603,-0.47719,0.11116/

!CODE:

      SQSGT = MAX(SQRT(SIG),0.00001)
      GAM = MAX(GAM,0.00001)
      FWHG = STOFW*SQSGT
      PGL = FWHG**5
      SUMHM = PGL
      DSDL = 0.0
      DSDG = 0.0
      DO ITRM=1,5
        PGL = PGL/FWHG
        DSDL = DSDL+FLOAT(ITRM)*COFT(ITRM+1)*PGL
        DSDG = DSDG+FLOAT(6-ITRM)*COFT(ITRM)*PGL
        PGL = PGL*GAM
        SUMHM = SUMHM+COFT(ITRM+1)*PGL
      END DO
      FWHM = EXP(0.2*LOG(SUMHM))
      FRAC = GAM/FWHM
      DEDF = 0.0
      PF = 1.0
      ETA = 0.0
      DO ITRM=1,3
        DEDF = DEDF+FLOAT(ITRM)*COFN(ITRM)*PF
        PF = PF*FRAC
        ETA = ETA+COFN(ITRM)*PF
      END DO

      NORM = 0.5*ALP*BET/(ALP+BET)
      SIGP = (FWHM/STOFW)**2
      TJ1 = ALP*SIGP
      TJ2 = BET*SIGP
      SQSG = SQRT(2.0*SIGP)
      S2SG = 2.0*SQSG*SIGP
      Y1 = (TJ1+DT)/SQSG
      DY1DS = (TJ1-DT)/S2SG
      Y2 = (TJ2-DT)/SQSG
      DY2DS = (TJ2+DT)/S2SG
      EX1 = -0.5*(DT**2)/SIGP
      DEXDS = -EX1/SIGP
      H1 = HFUNC(EX1,Y1,0,DH1DY)
      H2 = HFUNC(EX1,Y2,0,DH2DY)

      TG = NORM*(H1+H2)

      DTGDA = 2.0*NORM*TG/(ALP*ALP)
      DTGDA = DTGDA+0.5*NORM*SQSG*DH1DY                  !OK
      DTGDB = 2.0*NORM*TG/(BET*BET)
      DTGDB = DTGDB+0.5*NORM*SQSG*DH2DY                  !OK
      DTGDFW = TG*DEXDS+NORM*(DH1DY*DY1DS+DH2DY*DY2DS)
      DTGDFW = 2.0*DTGDFW*FWHM/STOFW**2                  !OK
      DTGDT = -NORM*(ALP*H1-BET*H2)                        !OK

      RXA = -ALP*DT
      RXB = -BET*DT
      IXA = ALP*FWHM/2.0
      IXB = BET*FWHM/2.0
      CALL EXPINT(RXA,IXA,RFA,IFA)
      CALL EXPINT(RXB,IXB,RFB,IFB)
      TL = -2.0*NORM*(IFA+IFB)/PI
      DIVSOR = DT**2+FWHM**2/4.0
      DTLDT = -2.0*NORM*(ALP*IFA+BET*IFB+FWHM/DIVSOR)/PI      !OK

      DTLDFW = NORM*(-ALP*RFA-BET*RFB-2.0*DT/DIVSOR)/PI

      DTLDA = 2.0*NORM*TL/ALP**2
      DTLDA = DTLDA+2.0*NORM*(DT*IFA-FWHM*RFA/2.0)/PI            !OK
      DTLDB = 2.0*NORM*TL/BET**2
      DTLDB = DTLDB+2.0*NORM*(DT*IFB-FWHM*RFB/2.0)/PI            !OK

      FUNC = ETA*TL+(1.0-ETA)*TG                        !OK

      DFDX = ETA*DTLDT+(1.0-ETA)*DTGDT

      DFWDG = 0.2*DSDG*FWHM/SUMHM
      DFRDG = -FRAC*DFWDG/FWHM

      DFDS = DEDF*DFRDG*(TL-TG)
      DFDS = DFDS+(ETA*DTLDFW+(1.0-ETA)*DTGDFW)*DFWDG
      DFDS = 0.5*DFDS*STOFW/SQSGT                        !OK

      DFWDL = 0.2*DSDL*FWHM/SUMHM
      DFRDL = (1.0-FRAC*DFWDL)/FWHM

      DFDG = DEDF*DFRDL*(TL-TG)
      DFDG = DFDG+(ETA*DTLDFW+(1.0-ETA)*DTGDFW)*DFWDL            !OK

      DFDA = ETA*DTLDA+(1.0-ETA)*DTGDA                  !OK

      DFDB = ETA*DTLDB+(1.0-ETA)*DTGDB                  !OK

      RETURN
      END


subroutine calc_gradient(t0,IPP)

    use global, only: uu,vv,dic,djc,dkc,dif,djf,dkf,pi2c,pj2c,pk2c,pi2f,pj2f,grad,npts,dxg_r,dyg_r,Npts
    implicit none
    integer*8, intent(in) :: IPP,t0
    real*8 :: tmp0,tmp1,dx,dy,dr
    integer*8:: i,j,k,ip

!$OMP PARALLEL DO PRIVATE(ip,i,j,k,dx,dy,dr,tmp0,tmp1) SHARED(IPP,t0,dic,djc,dkc,uu,vv,grad,dxg_r,dyg_r) SCHEDULE(dynamic)
    do ip=1,npts

        dx=dif(ip,IPP)
        dy=djc(ip,IPP)
        dr=dkc(ip,IPP)

        !du/dx
        i=pi2f(ip,IPP)
        j=pj2c(ip,IPP)
        k=pk2c(ip,IPP)
        call interp_bilinear(dy,dr,uu(i,j:j+1,k:k+1,t0),tmp0)
        call interp_bilinear(dy,dr,uu(i+1,j:j+1,k:k+1,t0),tmp1)
        grad(ip,1,IPP)=(tmp1-tmp0)*dxg_r(i,j)
        !du/dy
        call interp_bilinear(dx,dr,uu(i:i+1,j,k:k+1,t0),tmp0)
        call interp_bilinear(dx,dr,uu(i:i+1,j+1,k:k+1,t0),tmp1)
        grad(ip,2,IPP)=(tmp1-tmp0)*dyg_r(i,j)

        !dv/dx
        i=pi2c(ip,IPP)
        j=pj2f(ip,IPP)

        dy=djf(ip,IPP)
        dx=dic(ip,IPP)

        call interp_bilinear(dy,dr,vv(i,j:j+1,k:k+1,t0),tmp0)
        call interp_bilinear(dy,dr,vv(i+1,j:j+1,k:k+1,t0),tmp1)
        grad(ip,3,IPP)=(tmp1-tmp0)*dxg_r(i,j)
        !dv/dy

        call interp_bilinear(dx,dr,vv(i:i+1,j,k:k+1,t0),tmp0)
        call interp_bilinear(dx,dr,vv(i:i+1,j+1,k:k+1,t0),tmp1)
        grad(ip,4,IPP)=(tmp1-tmp0)*dyg_r(i,j)

    enddo
!$OMP END PARALLEL DO

end subroutine calc_gradient


#include "eiscor.h"
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! ZARGTD (Zomplex Auxiliary Routine Givens Through Diagonal)
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! This routine passes the generator for a Givens rotation represented
! by 3 real numbers: the real and imaginary parts of a complex cosine
! and a scrictly real sine through a 2x2 complex diagonal matrix
! represented by 4 real numbers.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! INPUT VARIABLES:
!
!  JOB             CHARACTER
!                    'L': pass rotation from Left of diagonal to right
!                    'R': pass rotation from Right of diagonal to left
!
!  D               REAL(8) array of dimension (4)
!                    array of generators for complex diagonal matrix
!
!  B               REAL(8) array of dimension (3)
!                    generator for a Givens rotation
!
! OUTPUT VARIABLES:
!
!  INFO           INTEGER
!                    INFO = 0 implies successful computation
!                    INFO = -1 implies JOB is invalid
!                    INFO = -2 implies D is invalid
!                    INFO = -3 implies B is invalid
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine ZARGTD(JOB,D,B,INFO)

  implicit none

  ! input variables
  character, intent(in) :: JOB
  integer, intent(inout) :: INFO
  real(8), intent(inout) :: D(4), B(3)

  ! compute variables
  integer :: ii
  real(8) :: c1r, c1i, s1
  real(8) :: d1r, d1i
  real(8) :: d2r, d2i
  real(8) :: nrm

  ! initialize INFO
  INFO = 0

  ! check input in debug mode
  if (DEBUG) then

    ! check JOB
    if ((JOB.NE.'L').AND.(JOB.NE.'R')) then
      INFO = -1
      call UARERR(__FILE__,__LINE__,"JOB must be 'L' or 'R'",INFO,INFO)
      return
    end if

    ! check D
    call DARACH1(4,D,INFO)
    if (INFO.NE.0) then
      call UARERR(__FILE__,__LINE__,"D is invalid",INFO,-2)
      return
    end if

    ! check B
    call DARACH1(3,B,INFO)
    if (INFO.NE.0) then
      call UARERR(__FILE__,__LINE__,"B is invalid",INFO,-3)
      return
    end if

  end if

  ! set inputs
  c1r = B(1)
  c1i = B(2)
  s1 = B(3)

  ! retrieve D
  d1r = D(1)
  d1i = D(2)
  d2r = D(3)
  d2i = D(4)

  !if JOB == L
  if (JOB.EQ.'L')then
    ! pass through diagonal
    nrm = (d1r*d2r + d1i*d2i)*c1r - (-d1r*d2i + d1i*d2r)*c1i
    c1i = (d1r*d2r + d1i*d2i)*c1i + (-d1r*d2i + d1i*d2r)*c1r
    c1r = nrm

    ! renormalize
    nrm = sqrt(c1r*c1r + c1i*c1i + s1*s1) ! not a good normalization, is that a problem?
    c1r = c1r/nrm
    c1i = c1i/nrm
    s1 = s1/nrm
  ! if JOB == R
  else
    ! pass through diagonal
    nrm = (d1r*d2r + d1i*d2i)*c1r - (-d1r*d2i + d1i*d2r)*c1i
    c1i = (d1r*d2r + d1i*d2i)*c1i + (-d1r*d2i + d1i*d2r)*c1r
    c1r = nrm

    ! renormalize
    nrm = sqrt(c1r*c1r + c1i*c1i + s1*s1) ! not a good normalization, is that a problem?
    c1r = c1r/nrm
    c1i = c1i/nrm
    s1 = s1/nrm
  end if

  ! set B
  B(1) = c1r
  B(2) = c1i
  B(3) = s1

  ! set D
  D(1) = d2r
  D(2) = d2i
  D(3) = d1r
  D(4) = d1i

end subroutine ZARGTD


      SUBROUTINE XYTICS (IOUT,OUT,NDEVIS,R1,R2,ISKIP,LOG,IFLAG)
C
C     THIS SUBROUTINE PERFORMS ONLY TIC COMPUTATIONS FOR XYDUMP.
C
      INTEGER IOUT(8)
      REAL    OUT(8),LENGTH
C
      IF (LOG .NE. 0) GO TO 70
      IF (R1 .EQ. R2) R2 = R1 + 1.0
      DIV = NDEVIS
      IF (DIV .LE. 0.0) DIV = 5.0
      LENGTH = R2 - R1
      IF (IFLAG  .NE. 0  ) DIV = LENGTH
      IF (LENGTH .LE. 0.0) GO TO 50
      FINC = 1.0001*LENGTH/DIV
C
C     CONVERT FINC TO SCIENTIFIC AND ROUND OFF TO 1 DIGIT (1 TO 10)
C
      IPOWER = 0
      IF (FINC .LT.  1.0) GO TO 20
   10 IF (FINC .LT. 10.0) GO TO 30
      IPOWER = IPOWER + 1
      FINC   = FINC/10.0
      GO TO 10
   20 IPOWER = IPOWER - 1
      FINC = FINC*10.0
      IF (FINC .LT. 1.0) GO TO 20
   30 IINC = 10
      IF (FINC .LT. 7.5) IINC = 5
      IF (FINC .LT. 3.5) IINC = 2
      IF (FINC .LT. 1.5) IINC = 1
C
C     ACTUAL INCREMENT
C
      FINC = FLOAT(IINC)*10.0**IPOWER
C
C     COMPUTE FIRST DIVISION POINT
C
      NFIRST = R1*10.0**(-IPOWER) + SIGN(0.555,R1)
C
C     GUARANTEE THAT TICKS WILL STEP THROUGH ZERO
C
      NTEMP  = NFIRST/IINC
      NFIRST = NTEMP*IINC
      FIRST  = FLOAT(NFIRST)*10.0**(IPOWER)
C
C     GET LOWEST VALUE OF FRAME
C
      IF (FIRST .LE. R1) GO TO 35
C
C     CHECK ABAINST EPSILON DIFFERENCE.  SENSITIVE TO TRUNCATION
C
      LENGTH = FINC*1.0E-4
      IF (FIRST-R1 .LT. LENGTH) FIRST = FIRST - LENGTH
      IF (FIRST-R1 .GE. LENGTH) FIRST = FIRST - FINC
      NFIRST = FIRST*10.0**(-IPOWER) + SIGN(0.5,R1)
   35 ITICS  = (R2-FIRST)/FINC + 1.5
      TEMP   = FLOAT(ITICS-1)*FINC + FIRST
      ENDV   = TEMP
      IF (ENDV .GE. R2) GO TO 37
      LENGTH = FINC*2.0E-4
      IF (ENDV+LENGTH .GE. R2)  ENDV = ENDV + LENGTH
      IF (ENDV+LENGTH .LT. R2)  ENDV = ENDV + FINC
      ITICS = (ENDV-FIRST)/FINC + 0.5
      TEMP  = FLOAT(ITICS-1)*FINC + FIRST
   37 CONTINUE
      IF (ENDV-TEMP .LT. FINC/4.0) ITICS = ITICS - 1
C
C     FIND MAXIMUM NUMBER OF DIGITS
C
      LAST   = NFIRST + IINC*ITICS
      LAST   = MAX0(IABS(LAST),IABS(NFIRST))
      MAXDIG = 1
   40 IF (LAST .LT. 10) GO TO 60
      MAXDIG = MAXDIG + 1
      LAST   = LAST/10
      GO TO 40
C
C     LENGTH = 0
C
   50 ITICS   = 0
   60 OUT(1)  = FIRST
      OUT(2)  = FINC
      OUT(3)  = ENDV
      IOUT(4) = MAXDIG
      IOUT(5) = IPOWER
      IOUT(6) = ITICS
      IOUT(7) = ISKIP
      RETURN
C
C     LOG SCALE - INITIAL LABELING CALCULATED
C
   70 FIRST  = R1
      ITICS  = LOG
      ENDV   = R2
      FINC   = 10.0
      MAXDIG = 1
      IPOWER = 0
      GO TO 60
C
      END