!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Compute mean 2PCF multipoles from Nres=1000 EZmocks
! for any issue please contact ginevra.favole@port.ac.uk
!-------------------------------------------------------
!compile as:
!  ifort -fopenmp mean_multipoles_rsd.f90 -o meanmrsd
!execute as:
! ./meanmrsd

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

program main
implicit none
CHARACTER(len=150) :: FN
CHARACTER(len=150) :: GN
CHARACTER(150), PARAMETER   :: output='../multipoles_EZmocks3Gpc/multipoles_5Mpc/mean_multipoles_rsd.txt'

integer, parameter :: Nres=999,cov_num=40
integer :: i, j, k, io, N_halsum
real*8 :: mxi0(1:cov_num), mxi2(1:cov_num), mxi4(1:cov_num), s(1:cov_num), temp
real*8, dimension(:), allocatable  :: bin_mock, xi0_mock, xi2_mock, xi4_mock

!------------------------------------------------ format input read all
mxi0=0.0
mxi2=0.0
mxi4=0.0

DO I=0,Nres
WRITE(FN,10)I
WRITE(6,*)FN
j=1
OPEN(1,FILE=FN)
DO
READ(1,*,IOSTAT=io) temp
IF (io < 0) THEN
N_halsum = j-1
EXIT
ENDIF
j =j+1
ENDDO

allocate(bin_mock(1:N_halsum),xi0_mock(1:N_halsum),xi2_mock(1:N_halsum),xi4_mock(1:N_halsum))
rewind(1)
do k=1,N_halsum
read(1,*,IOSTAT=io) bin_mock(k),xi0_mock(k),xi2_mock(k),xi4_mock(k)
enddo

do k=1,N_halsum
s(k) = bin_mock(k)
mxi0(k) = mxi0(k)+xi0_mock(k)
mxi2(k) = mxi2(k)+xi2_mock(k)
mxi4(k) = mxi4(k)+xi4_mock(k)
enddo
CLOSE(1)
DEALLOCATE(bin_mock, xi0_mock, xi2_mock, xi4_mock)
ENDDO

open(unit=1020,file=output)
do k=1,N_halsum
mxi0(k) = mxi0(k)/dble(Nres+1.)
mxi2(k) = mxi2(k)/dble(Nres+1.)
mxi4(k) = mxi4(k)/dble(Nres+1.)
write(1020,'(f10.4,x,f20.8,x,f20.8,x,f20.8)') s(k), mxi0(k), mxi2(k), mxi4(k)
enddo
close(1020)

10 FORMAT('../multipoles_EZmocks3Gpc/multipoles_5Mpc/xilrsd_',I3.3,'.txt')
end program


program main
    use FEMDomainClass
    implicit none

    type(FEMDomain_) :: mesh
    integer(int32) :: nearest_node_id

    ! detect nearest node
    call mesh%create(meshtype="Cube")
    call mesh%resize(x=10.0d0,y=10.0d0,z=10.0d0)
    nearest_node_id = mesh%getNearestNodeID(x=1.0d0,y=1.0d0,z=9.0d0)
    print *, nearest_node_id, mesh%position(nearest_node_id)

end program main


subroutine caldat(ijulian,dd,mm,yyyy)
!
implicit none
!
include 'm1sim.inc'
!
! PARAMETER definitions
!
integer,parameter :: igreg = 2299161
!
! Dummy arguments
!
integer :: dd,ijulian,mm,yyyy
!
! Local variables
!
real :: alpha,c,e
real*8 :: dble
integer :: int
integer :: ja,jalpha,jb,jc,jd,je,julian
!
!     + + + purpose + + +
!     inverse of the function julday. here 'julian' is input as a julian day
!     number, and the routine outputs the dd, mm, and yyyy on which the
!     specified julian day started at noon.
!
!     + + + keywords + + +
!     date, utility
!
!     + + + argument declarations + + +
!
!     + + + argument definitions + + +
!     mm     - integer value of mm in the range 1-12
!     dd     -                  dd in the range 1-31
!     yyyy   -                  yyyy (negative a.d., positive b.c.)
!     ijulian - julian day value (this is the value passed into caldat.
!               definition taken from lstday)
!     julian - integer value equal to julian day number
!
!     + + + parameters + + +
!     gregorian calendar was adopted on oct. 15, 1582.
!     igreg - parameter

!     + + + parameter definitions + + +

!     + + + local variables + + +

!     + + + local variable definitions + + +
!     alpha -
!     c -
!     dble - double
!     e -
!     int -
!     ja -
!     jalpha -
!     jb -
!     jc -
!     jd -
!     je -

!     + + + common block variable definitions + + +
!     am0jd - current julian day of simulation

!     + + + end specifications + + +
!

!     if the date is -1 then use the simulation date.

julian = ijulian
if (julian==-1) julian = am0jd

if (julian>=igreg) then
  alpha = (dble(julian-1867216)-dble(0.25))/dble(36524.25)
  jalpha = int(alpha)
  ja = julian + 1 + jalpha - int(dble(0.25)*jalpha)
else
  ja = julian
end if
jb = ja + 1524
c = dble(6680.0) + ((jb-2439870)-dble(122.1))/dble(365.25)
!c = dble(6680.0) + ((jb-2439870)-dble(122.1))/dble(365.00)!de changed
jc = int(c)
jd = 365*jc + int(dble(0.25)*jc)
e = (jb-jd)/dble(30.6001)
je = int(e)
dd = jb - jd - int(dble(30.6001)*je)
mm = je - 1
if (mm>12) mm = mm - 12
yyyy = jc - 4715
if (mm>2) yyyy = yyyy - 1
if (yyyy<=0) yyyy = yyyy - 1
!
end subroutine caldat


! { dg-do run }
! { dg-options "-fcray-pointer -ffloat-store" }
!
! Test the fix for PR36528 in which the Cray pointer was not passed
! correctly to 'euler' so that an undefined reference to fcn was
! generated by the linker.
!
! Reported by Tobias Burnus  <burnus@gcc.gnu.org>
! from http://groups.google.com/group/comp.lang.fortran/msg/86b65bad78e6af78
!
real function p1(x)
  real, intent(in) :: x
  p1 = x
end

real function euler(xp,xk,dx,f)
  real, intent(in) :: xp, xk, dx
  interface
    real function f(x)
      real, intent(in) :: x
    end function
  end interface
  real x, y
  y = 0.0
  x = xp
  do while (x .le. xk)
    y = y + f(x)*dx
    x = x + dx
  end do
  euler = y
end
program main
  interface
    real function p1 (x)
      real, intent(in) :: x
    end function
    real function fcn (x)
      real, intent(in) :: x
    end function
    real function euler (xp,xk,dx,f)
      real, intent(in) :: xp, xk ,dx
      interface
        real function f(x)
          real, intent(in) :: x
        end function
      end interface
    end function
  end interface
  real x, xp, xk, dx, y, z
  pointer (pfcn, fcn)
  pfcn = loc(p1)
  xp = 0.0
  xk = 1.0
  dx = 0.0005
  y = 0.0
  x = xp
  do while (x .le. xk)
    y = y + fcn(x)*dx
    x = x + dx
  end do
  z = euler(0.0,1.0,0.0005,fcn)
  if (abs (y - z) .gt. 1e-6) STOP 1
end


*DECK DCOT
      DOUBLE PRECISION FUNCTION DCOT (X)
C***BEGIN PROLOGUE  DCOT
C***PURPOSE  Compute the cotangent.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C4A
C***TYPE      DOUBLE PRECISION (COT-S, DCOT-D, CCOT-C)
C***KEYWORDS  COTANGENT, ELEMENTARY FUNCTIONS, FNLIB, TRIGONOMETRIC
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C DCOT(X) calculates the double precision trigonometric cotangent
C for double precision argument X.  X is in units of radians.
C
C Series for COT        on the interval  0.          to  6.25000E-02
C                                        with weighted error   5.52E-34
C                                         log weighted error  33.26
C                               significant figures required  32.34
C                                    decimal places required  33.85
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  D1MACH, DCSEVL, INITDS, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770601  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   920618  Removed space from variable names.  (RWC, WRB)
C***END PROLOGUE  DCOT
      DOUBLE PRECISION X, COTCS(15), AINTY, AINTY2, PI2REC, SQEPS,
     1  XMAX, XMIN, XSML, Y, YREM, PRODBG, DCSEVL, D1MACH
      LOGICAL FIRST
      SAVE COTCS, PI2REC, NTERMS, XMAX, XSML, XMIN, SQEPS, FIRST
      DATA COTCS(  1) / +.2402591609 8295630250 9553617744 970 D+0    /
      DATA COTCS(  2) / -.1653303160 1500227845 4746025255 758 D-1    /
      DATA COTCS(  3) / -.4299839193 1724018935 6476228239 895 D-4    /
      DATA COTCS(  4) / -.1592832233 2754104602 3490851122 445 D-6    /
      DATA COTCS(  5) / -.6191093135 1293487258 8620579343 187 D-9    /
      DATA COTCS(  6) / -.2430197415 0726460433 1702590579 575 D-11   /
      DATA COTCS(  7) / -.9560936758 8000809842 7062083100 000 D-14   /
      DATA COTCS(  8) / -.3763537981 9458058041 6291539706 666 D-16   /
      DATA COTCS(  9) / -.1481665746 4674657885 2176794666 666 D-18   /
      DATA COTCS( 10) / -.5833356589 0366657947 7984000000 000 D-21   /
      DATA COTCS( 11) / -.2296626469 6464577392 8533333333 333 D-23   /
      DATA COTCS( 12) / -.9041970573 0748332671 9999999999 999 D-26   /
      DATA COTCS( 13) / -.3559885519 2060006400 0000000000 000 D-28   /
      DATA COTCS( 14) / -.1401551398 2429866666 6666666666 666 D-30   /
      DATA COTCS( 15) / -.5518004368 7253333333 3333333333 333 D-33   /
      DATA PI2REC / .01161977236 7581343075 5350534900 57 D0 /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  DCOT
      IF (FIRST) THEN
         NTERMS = INITDS (COTCS, 15, 0.1*REAL(D1MACH(3)) )
         XMAX = 1.0D0/D1MACH(4)
         XSML = SQRT(3.0D0*D1MACH(3))
         XMIN = EXP (MAX(LOG(D1MACH(1)), -LOG(D1MACH(2))) + 0.01D0)
         SQEPS = SQRT(D1MACH(4))
      ENDIF
      FIRST = .FALSE.
C
      Y = ABS(X)
      IF (Y .LT. XMIN) CALL XERMSG ('SLATEC', 'DCOT',
     +   'ABS(X) IS ZERO OR SO SMALL DCOT OVERFLOWS', 2, 2)
      IF (Y .GT. XMAX) CALL XERMSG ('SLATEC', 'DCOT',
     +   'NO PRECISION BECAUSE ABS(X) IS TOO BIG', 3, 2)
C
C CAREFULLY COMPUTE Y * (2/PI) = (AINT(Y) + REM(Y)) * (.625 + PI2REC)
C = AINT(.625*Y) + REM(.625*Y) + Y*PI2REC  =  AINT(.625*Y) + Z
C = AINT(.625*Y) + AINT(Z) + REM(Z)
C
      AINTY = AINT (Y)
      YREM = Y - AINTY
      PRODBG = 0.625D0*AINTY
      AINTY = AINT (PRODBG)
      Y = (PRODBG-AINTY) + 0.625D0*YREM + PI2REC*Y
      AINTY2 = AINT (Y)
      AINTY = AINTY + AINTY2
      Y = Y - AINTY2
C
      IFN = MOD (AINTY, 2.0D0)
      IF (IFN.EQ.1) Y = 1.0D0 - Y
C
      IF (ABS(X) .GT. 0.5D0 .AND. Y .LT. ABS(X)*SQEPS) CALL XERMSG
     +   ('SLATEC', 'DCOT',
     +   'ANSWER LT HALF PRECISION, ABS(X) TOO BIG OR X NEAR N*PI ' //
     +   '(N.NE.0)', 1, 1)
C
      IF (Y.GT.0.25D0) GO TO 20
      DCOT = 1.0D0/X
      IF (Y.GT.XSML) DCOT = (0.5D0 + DCSEVL (32.0D0*Y*Y-1.D0, COTCS,
     1  NTERMS)) / Y
      GO TO 40
C
 20   IF (Y.GT.0.5D0) GO TO 30
      DCOT = (0.5D0 + DCSEVL (8.D0*Y*Y-1.D0, COTCS, NTERMS))/(0.5D0*Y)
      DCOT = (DCOT*DCOT-1.D0)*0.5D0/DCOT
      GO TO 40
C
 30   DCOT = (0.5D0 + DCSEVL (2.D0*Y*Y-1.D0, COTCS, NTERMS))/(.25D0*Y)
      DCOT = (DCOT*DCOT-1.D0)*0.5D0/DCOT
      DCOT = (DCOT*DCOT-1.D0)*0.5D0/DCOT
C
 40   IF (X.NE.0.D0) DCOT = SIGN (DCOT, X)
      IF (IFN.EQ.1) DCOT = -DCOT
C
      RETURN
      END


C     ******************************************************************
C     ******************************************************************

      subroutine spgls(n,x,l,u,m,lambda,rho,equatn,linear,f,g,lamspg,
     +xp,fp,alpha,d,evalaldim,setpdim,lsinfo,inform)

      implicit none

C     SCALAR ARGUMENTS
      integer inform,lsinfo,m,n
      double precision alpha,f,fp,lamspg

C     ARRAY ARGUMENTS
      logical equatn(m),linear(m)
      double precision d(n),g(n),l(n),lambda(m),rho(m),u(n),x(n),xp(n)

C     SUBROUTINE ARGUMENTS
      external evalaldim,setpdim

C     This subroutine computes a line search in the Spectral Projected
C     Gradient direction.
C
C     lsinfo:
C
C     0: Armijo satisfied
C     1: Small step with functional value similar to the current one
C     2: Unbounded objective function?
C     3: Too small backtracking step. Wrong gradient?

      include "dim.par"
      include "outtyp.inc"
      include "counters.inc"

C     LOCAL SCALARS
      integer i
      double precision dsupn,gtd,xsupn

C     ------------------------------------------------------------------
C     Compute search direction, directional derivative, dsupn, xsupn and
C     first trial
C     ------------------------------------------------------------------

      gtd   = 0.0d0
      dsupn = 0.0d0
      xsupn = 0.0d0
      do i = 1,n
          d(i)  = - lamspg * g(i)
          xp(i) = x(i) + d(i)
          if ( xp(i) .lt. l(i) .or. xp(i) .gt. u(i) ) then
              xp(i) = max( l(i), min( xp(i), u(i) ) )
              d(i)  = xp(i) - x(i)
          end if
          gtd   = gtd + g(i) * d(i)
          dsupn = max( dsupn, abs( d(i) ) )
          xsupn = max( xsupn, abs( x(i) ) )
      end do

      if ( iprintinn .ge. 6 ) then
C          write(* ,100) xsupn,lamspg,dsupn
          write(10,100) xsupn,lamspg,dsupn
      end if

      call setpdim(n,xp)

      call evalaldim(n,xp,m,lambda,rho,equatn,linear,fp,inform)
      if ( inform .lt. 0 ) return

      alpha = 1.0d0

      if ( iprintinn .ge. 6 ) then
C          write(*, 110) alpha,fp,fcnt
          write(10,110) alpha,fp,fcnt
      end if

C     ==================================================================
C     Backtracking
C     ==================================================================

      call backtracking(n,x,m,lambda,rho,equatn,linear,f,d,gtd,alpha,fp,
     +xp,evalaldim,setpdim,lsinfo,inform)
      if ( inform .lt. 0 ) return

C     ==================================================================
C     End of backtracking
C     ==================================================================

C     NON-EXECUTABLE STATEMENTS

 100  format(/,5X,'SPG Line search (xsupn = ',1P,D7.1,1X,'SPGstep= ',
     +             1P,D7.1,1X,'dsupn = ',1P,D7.1,')')
 110  format(  5X,'Alpha = ',1P,D7.1,' F = ',1P,D24.16,' FE = ',I7)

      end


cccccccccccccccccccccccccccccccccccccccccccccccc
c create geoma parameters...

      subroutine compute_geo(res,os_res,geo)
      implicit none
c inputs...
      real*4 res(2,202)		!image space coordinates
      real*4 os_res(2,202)	!object space coordinates
c output...
      real*4 geo(4,24,23)	!quad grid in geoma format
c local variables..
      real*4 is(2,13,23)	!IS coordinates of triangular grid
      real*4 os(2,13,23)	!OS coordinates of triangular grid
      integer row
      logical xvptst

      do row=1,23
         call interg(res,os_res,row,is(1,1,row),os(1,1,row))
         call triag(row,is(1,1,row),os(1,1,row),geo(1,1,row))
      enddo

      if (xvptst('pgeo')) call print_rows(is,os)
      return
      end


      program loopinit

c     Check that loop index initialization is performed correctly

      real t(10)

      j = 2

      do i = inc(j), n, 1
         t(i) = 0.
         j = j + 2
      enddo

      print *, i, j

      end

      integer function inc(k)
      k = k + 1
      inc = k
      end


C    Copyright(C) 1999-2020 National Technology & Engineering Solutions
C    of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C    NTESS, the U.S. Government retains certain rights in this software.
C
C    See packages/seacas/LICENSE for details

      SUBROUTINE POINT3 (COORD, NUMNP, DIST, NDIM, P1, TOLER,
     *   NODEL, SORTYP, MAP, ANGLE, SORUP, INUM, OPT, SELECT)
      DIMENSION COORD (NUMNP,*), DIST(*), P1(*), TOLER(*),
     *   MAP(*), ANGLE(2,*)
      CHARACTER*(*) NODEL, SORTYP, OPT
      LOGICAL SORUP, SELECT(*), ISABRT
      include 'nu_io.blk'
      PI = ATAN2(0.0, -1.0)

      CALL LOCOUT ('POINT', NDIM, NODEL, TOLER, SORTYP, P1, P1, ' ')

      TEMP = TOLER(1)
      TOLER(1) = MAX(0.0, TEMP - TOLER(2))
      TOLER(2) = MAX(0.0, TEMP + TOLER(2))

      X1 = P1(1)
      Y1 = P1(2)
      Z1 = P1(3)

      DO 10 I=1, NUMNP
         IF (SELECT(I)) THEN
         X0 = COORD(I,1)
         Y0 = COORD(I,2)
         Z0 = COORD(I,3)

         DIST(I) = (X1 - X0)**2 + (Y1 - Y0)**2 + (Z1 - Z0)**2
         END IF
   10 CONTINUE

      INUM = 0
      DISMIN = 1.0E38
      DO 20 I=1, NUMNP
         IF (SELECT(I)) THEN
         DISMIN = MIN(DIST(I), ABS(DISMIN-TEMP))
         IF (DIST(I) .GE. TOLER(1)**2 .AND. DIST(I) .LE. TOLER(2)**2)
     *      THEN
            DX = COORD(I,1) - P1(1)
            DY = COORD(I,2) - P1(2)
            DZ = COORD(I,3) - P1(3)
            DS = SQRT(DX**2 + DZ**2)

            FIX1 = SIGN(0.5,ABS(DX+DZ)) + SIGN(0.5,-ABS(DX+DZ))
            FIX2 = SIGN(0.5,ABS(DS+DY)) + SIGN(0.5,-ABS(DS+DY))
            ANGLE(1,I) = ATAN2(DZ,DX+FIX1) * 180.0 / PI
            ANGLE(2,I) = ATAN2(DY,DS+FIX2) * 180.0 / PI

            INUM = INUM + 1
            MAP(INUM) = I
         END IF
         END IF
   20 CONTINUE

      IF      (SORTYP .EQ. 'X') THEN
         CALL INDEXX (COORD(1,1), MAP, INUM, .FALSE.)
      ELSE IF (SORTYP .EQ. 'Y') THEN
         CALL INDEXX (COORD(1,2), MAP, INUM, .FALSE.)
      ELSE IF (SORTYP .EQ. 'Z') THEN
         CALL INDEXX (COORD(1,3), MAP, INUM, .FALSE.)
      ELSE IF (SORTYP .EQ. 'THETA') THEN
         CALL INDEXN (ANGLE,      2, 1, MAP, INUM, .FALSE.)
      ELSE IF (SORTYP .EQ. 'PHI') THEN
         CALL INDEXN (ANGLE,      2, 2, MAP, INUM, .FALSE.)
      ELSE IF (SORTYP .EQ. 'DISTANCE') THEN
         CALL INDEXX (DIST,       MAP, INUM, .FALSE.)
      END IF

      IF (SORUP) THEN
         IBEG = 1
         IEND = INUM
         IINC = 1
      ELSE
         IBEG = INUM
         IEND = 1
         IINC = -1
      END IF

      IF (OPT .EQ. '*' .OR. INDEX(OPT, 'P') .GT. 0) THEN
      DO 30 IO=IOMIN, IOMAX
         WRITE (IO, 40) NODEL
   30 CONTINUE
   40 FORMAT (/,2X,A8,T16,'X',T26,'Y',T36,'Z',T44,'DISTANCE',
     *   T58,'THETA',T71,'PHI')
      DO 60 IN = IBEG, IEND, IINC
         IF (ISABRT()) RETURN
         I = MAP(IN)
         DO 50 IO=IOMIN, IOMAX
            WRITE (IO, 90) I, (COORD(I,J),J=1,3), SQRT(DIST(I)),
     *         ANGLE(1,I), ANGLE(2,I)
   50    CONTINUE
   60 CONTINUE

      IF (INUM .EQ. 0) THEN
         DO 70 IO=IOMIN, IOMAX
            WRITE (IO, 80) SQRT(DISMIN)
   70    CONTINUE
      END IF
      END IF
   80 FORMAT (/' None found within range, minimum distance = ',
     *   1PE12.3,/)
   90 FORMAT (I10, 3(F10.4), 3(1PE12.3))
      RETURN
      END


c
c     version 1  Oct 1995
c
c     ----------------------------------------------------------------
c     |                                                              |
c     |           *******  S M O O T H L S Q R  *******              |
c     |                                                              |
c     |                 Least-squares solution of                    |
c     |                traveltime inversion problem                  |
c     |               using smoothing regularisation                 |
c     |                                                              |
c     |                   Written by C. A. Zelt                      |
c     |                 Modified by N. J. Bruguier                   |
c     |                                                              |
c     |                   Bullard Laboratories                       |
c     |                  Cambridge, CB3 0EZ, UK                      |
c     |                                                              |
c     ----------------------------------------------------------------
c
c
c     I/O units:
c
c        10 -- input:  damping parameters
c
c        11 -- input:  matrix of partial derivatives and vector of
c                      traveltime residuals
c
c        12 -- output: model parameter adjustments and resolution and
c                      covariance estimates and updated model
c
c        13 -- input/output: initial and updated velocity model
c
c        30 -- input:  initial and updated floating reflectors
c
c
c     ----------------------------------------------------------------
c
c
      program main
c
      include 'rayinvr.par'
c
      real apart(prayi,pnvar),tres(prayi),ata(pnvar,pnvar),
     +     att(pnvar),atad(pnvar,pnvar),atadi(pnvar,pnvar),
     +     dx(pnvar),res(pnvar,pnvar),var(pnvar),parorg(pnvar),
     +     xm(pncntr,ppcntr),zm(pncntr,ppcntr),grad(player*ppvel),
     +     xvel(player,ppvel,2),vf(player,ppvel,2),
     +     tunc(prayi),thick(player*ppcntr),parunc(pnvar),
     +     xfrefl(pfrefl,ppfref),zfrefl(pfrefl,ppfref),
     +     d(pnvar,pnvar),dtd(pnvar,pnvar),dtdm(pnvar),
     +     parbsf(pnvar),velw(9),bndw(9)
      integer partyp(pnvar),nzed(pncntr),nvel(player,2),
     +        ivarz(player,ppcntr),ivarv(player,ppvel,2),
     +        mpinch(pncntr,ppcntr,2),igrad(player*ppvel),
     +        ivarf(pfrefl,ppfref),npfref(pfrefl),parw(pnvar),
     +        iparz(player,ppcntr),iparv(player,ppvel,2)
c
      namelist /dmppar/ iscrn,ilayer,dmpfct,velunc,bndunc,xmax,
     +                  velw,bndw
c
      open(unit=10, file='d.in', status='old')
      open(unit=11, file='i.out', status='old')
      open(unit=12, file='d.out')
      open(unit=13, file='v.in', status='old')
      open(unit=14, file='v.bak')
c
c default parameter values
c
      iscrn=1
      ilayer=0
      dmpfct=1.0
      velunc=-1.
      bndunc=-1.
      xmax=-99999.
      ifrbnd=0
c
      read(10,dmppar)
c
      if(xmax.lt.-99998) then
        write(6,105)
105     format(/'***  xmax not specified  ***'/)
        stop
      end if
c
c read in matrix of partial derivatives
c and vector of traveltime residuals
c
      read(11,1)
1     format(' ')
      read(11,115) narinv,nvar
115   format(2i5)
      read(11,1)
      do 6 i=1,nvar
         read(11,5) partyp(i),parorg(i),parw(i)
5        format(i5,f15.5,i10)
6     continue
      read(11,1)
      do 10 i=1,narinv
         read(11,15) (apart(i,j),j=1,nvar)
15       format(5e12.5)
10    continue
      read(11,1)
      read(11,15) (tres(i),i=1,narinv)
      read(11,1)
      read(11,15) (tunc(i),i=1,narinv)
c
c parameter uncertainties
c
      do 70 i=1,nvar
         if(partyp(i).eq.1) then
            if(bndunc.le.0.) then
               parunc(i)=bndw(parw(i))**2
            else
               parunc(i)=bndunc**2
            end if
         end if
         if(partyp(i).eq.2) then
            if(velunc.le.0.) then
               parunc(i)=velw(parw(i))**2
            else
               parunc(i)=velunc**2
            end if
         end if
         if(partyp(i).eq.3) then
            if(bndunc.le.0.) then
               parunc(i)=bndw(parw(i))**2
            else
               parunc(i)=bndunc**2
            end if
            ifrbnd=1
         end if
70    continue
c
c read in velocity model
c
      ncont=1
      nrzmax=ppcntr/10
      nrvmax=ppvel/10
      do 170 icont=1,player+1
         nrz=1
         j1=1
         j2=10
11       if(nrz.gt.nrzmax) go to 211
         read(13,55,end=999) ilyr,(xm(icont,j),j=j1,j2)
         read(13,55,end=999) icnt,(zm(icont,j),j=j1,j2)
         read(13,65,end=99) (ivarz(icont,j),j=j1,j2)
55       format(i2,1x,10f7.2)
65       format(3x,10i7)
         nrz=nrz+1
         if(icnt.ne.1) go to 211
         j1=j1+10
         j2=j2+10
         go to 11
211      nrv=1
         j1=1
         j2=10
21       if(nrv.gt.nrvmax) go to 311
         read(13,55,end=999) ilyr,(xvel(icont,j,1),j=j1,j2)
         read(13,55,end=999) icnt,(vf(icont,j,1),j=j1,j2)
         read(13,65,end=999) (ivarv(icont,j,1),j=j1,j2)
         nrv=nrv+1
         if(icnt.ne.1) go to 311
         j1=j1+10
         j2=j2+10
         go to 21
311      nrv=1
         j1=1
         j2=10
31       if(nrv.gt.nrvmax) go to 411
         read(13,55,end=999) ilyr,(xvel(icont,j,2),j=j1,j2)
         read(13,55,end=999) icnt,(vf(icont,j,2),j=j1,j2)
         read(13,65,end=999) (ivarv(icont,j,2),j=j1,j2)
         nrv=nrv+1
         if(icnt.ne.1) go to 411
         j1=j1+10
         j2=j2+10
         go to 31
411      ncont=ncont+1
170   continue
c
99    nlayer=ncont-1
c
c calculate number of parameters per layer
c
      do 171 i=1,ncont
         nzed(i)=1
171   continue
      do 172 i=1,nlayer
         nvel(i,1)=1
         nvel(i,2)=1
172   continue
c
      do 180 i=1,ncont
         do 190 j=1,ppcntr
            if(abs(xm(i,j)-xmax).lt..0001) go to 180
            nzed(i)=nzed(i)+1
190      continue
180   continue
c
      do 210 i=1,nlayer
         do 220 j=1,ppvel
            if(abs(xvel(i,j,1)-xmax).lt..0001) go to 212
            nvel(i,1)=nvel(i,1)+1
220      continue
212      if(nvel(i,1).eq.1.and.vf(i,1,1).eq.0.) nvel(i,1)=0
210   continue
c
      do 240 i=1,nlayer
         do 250 j=1,ppvel
            if(abs(xvel(i,j,2)-xmax).lt..0001) go to 260
            nvel(i,2)=nvel(i,2)+1
250      continue
260      if(nvel(i,2).eq.1.and.vf(i,1,2).eq.0.) nvel(i,2)=0
240   continue
c
c read in floating reflectors
c
      if(ifrbnd.eq.1) then
        open(unit=30, file='f.in', status='old')
        open(unit=31, file='f.bak')
        nfrefl=0
690     read(30,545,end=595) nfrefr
        if(nfrefr.lt.2.or.nfrefr.gt.ppfref) then
          write(6,585)
585       format(/'***  error in f.in file  ***'/)
          stop
        end if
        nfrefl=nfrefl+1
        npfref(nfrefl)=nfrefr
545     format(i2)
        read(30,555) (xfrefl(nfrefl,i),i=1,npfref(nfrefl))
        read(30,555) (zfrefl(nfrefl,i),i=1,npfref(nfrefl))
        read(30,575) (ivarf(nfrefl,i),i=1,npfref(nfrefl))
555     format(3x,<ppfref>f7.2)
575     format(3x,<ppfref>i7)
        go to 690
595     continue
      end if
c
c change depths to layer thicknesses if required
c
      np=0
      if (ilayer.eq.1) then
        do 1281 i=2,nlayer
          do 1282 j=1,nzed(i)
            if(ivarz(i,j).gt.0) then
              np=np+1
              do 1284 k=1,nzed(i-1)
                if(abs(xm(i,j)-xm(i-1,k)).lt..005) then
                  parbsf(np)=zm(i,j)-zm(i-1,k)
                  goto 1282
                end if
1284          continue
            endif
1282      continue
c
          if (nvel(i,1).gt.0) then
            do 1285 j=1,nvel(i,1)
              if(ivarv(i,j,1).gt.0) then
                np=np+1
                parbsf(np)=parorg(np)
              end if
1285        continue
          end if
c
          if (nvel(i,2).gt.0) then
            do 1286 j=1,nvel(i,2)
              if(ivarv(i,j,2).gt.0) then
                np=np+1
                parbsf(np)=parorg(np)
              end if
1286        continue
          end if
1281   continue
c
       if(ifrbnd.eq.1) then
         do 1287 i=1,nfrefl
           do 1288 j=1,npfref(j)
             if(ivarf(i,j).eq.1) then
               np=np+1
               parbsf(np)=parorg(np)
             end if
1288       continue
1287     continue
      end if
c
      if(np.ne.nvar) goto 999
      endif
c
c calculate difference matrix D
c
      do 1250 i=1,nvar
         do 1260 j=1,nvar
            d(i,j)=0.
1260     continue
1250  continue
c
      np=0
c
      do 1270 i=1,nlayer
         do 1280 j=1,nzed(i)
            if(ivarz(i,j).gt.0) then
              np=np+1
              if(j.gt.1) then
                dist=xm(i,j)-xm(i,j-1)
                d(np,np)=1./dist
                d(np,np-1)=-1./dist
              endif
            end if
1280     continue
c
         if (nvel(i,1).gt.0) then
           do 1310 j=1,nvel(i,1)
             if(ivarv(i,j,1).gt.0) then
               np=np+1
               if(j.gt.1) then
                 dist=xvel(i,j,1)-xvel(i,j-1,1)
                 d(np,np)=1./dist
                 d(np,np-1)=-1./dist
               end if
             end if
1310       continue
         end if
c
         if (nvel(i,2).gt.0) then
           do 1430 j=1,nvel(i,2)
             if(ivarv(i,j,2).gt.0) then
               np=np+1
               if(j.gt.1) then
                 dist=xvel(i,j,2)-xvel(i,j-1,2)
                 d(np,np)=1./dist
                 d(np,np-1)=-1./dist
               end if
             end if
1430       continue
         end if
1270  continue
c
      if(ifrbnd.eq.1) then
        do 1880 i=1,nfrefl
          do 1890 j=1,npfref(j)
            if(ivarf(i,j).eq.1) then
              np=np+1
              if(j.gt.1) then
                dist=xfrefl(i,j)-xfrefl(i,j-1)
                d(np,np)=1./dist
                d(np,np-1)=-1./dist
              end if
            end if
1890      continue
1880    continue
      end if
c
      if(np.ne.nvar) goto 999
c
c calculate ATA
c
      do 20 i=1,nvar
         do 30 j=1,i
            ata(i,j)=0.
            do 40 k=1,narinv
               ata(i,j)=ata(i,j)+apart(k,i)*apart(k,j)/tunc(k)**2
40          continue
            if(i.ne.j) ata(j,i)=ata(i,j)
30       continue
20    continue
c
c calculate ATT
c
      do 50 i=1,nvar
         att(i)=0.
         do 60 j=1,narinv
            att(i)=att(i)+apart(j,i)*tres(j)/tunc(j)**2
60       continue
50    continue
c
c calculate DTD and (ATA+DTD)
c
      do 1520 i=1,nvar
         do 1530 j=1,nvar
           dtd(i,j)=0.
           do 1540 k=1,nvar
             dtd(i,j)=dtd(i,j)+d(k,i)*d(k,j)*dmpfct/parunc(k)
1540       continue
	   atad(i,j)=ata(i,j)+dtd(i,j)
1530     continue
1520  continue
c
c calculate DTDm
c
      if (ilayer.eq.1) then
        do 1550 i=1,nvar
          dtdm(i)=0.
          do 1560 j=1,nvar
             dtdm(i)=dtdm(i)+dtd(i,j)*parbsf(j)
1560      continue
1550    continue
      else
        do 1551 i=1,nvar
          dtdm(i)=0.
          do 1561 j=1,nvar
             dtdm(i)=dtdm(i)+dtd(i,j)*parorg(j)
1561      continue
1551    continue
      endif
c
c invert matrix (ATA+DTD)
c
      call matinv(atad,atadi,nvar)
c
c calculate parameter adjustments
c
      do 90 i=1,nvar
         dx(i)=0.
         do 100 j=1,nvar
            dx(i)=dx(i)+atadi(i,j)*(att(j)-dtdm(j))
100      continue
90    continue
c
c calculate resolution matrix
c
      do 110 i=1,nvar
         do 120 j=1,nvar
            res(i,j)=0.
            do 130 k=1,nvar
               res(i,j)=res(i,j)+atadi(i,k)*ata(k,j)
130         continue
120      continue
110   continue
c
c calculate variance
c
      do 140 i=1,nvar
         var(i)=var(i)+(1.0-res(i,i))*parunc(i)
140   continue
c
c output results
c
      write(12,25) dmpfct
25    format(/'overall damping factor: ',f10.2)
      write(12,35)
35    format(/'type  orig. val.  uncert.    adjust.   new val.',
     +        ' resolution std. error')
      write(12,45) (partyp(i),parorg(i),parunc(i)**.5,dx(i),
     +              parorg(i)+dx(i),res(i,i),sqrt(var(i)),i=1,nvar)
45    format(i3,6f11.4)
c
      if(iscrn.eq.1) then
        write(6,25) dmpfct
        write(6,35)
        write(6,45) (partyp(i),parorg(i),parunc(i)**.5,dx(i),parorg(i)+
     +               dx(i),res(i,i),sqrt(var(i)),i=1,nvar)
      end if
c
c write out original velocity model
c
      do 1570 i=1,nlayer
         nstart=1
1590     j1=nstart
         j2=j1+9
         if(j2.gt.nzed(i)) j2=nzed(i)
         if(j2.lt.nzed(i)) then
           icnt=1
         else
           icnt=0
         end if
         write(14,55) i,(xm(i,j),j=j1,j2)
         write(14,55) icnt,(zm(i,j),j=j1,j2)
         write(14,65) (ivarz(i,j),j=j1,j2)
         if(j2.eq.nzed(i)) go to 1600
         nstart=j2+1
         go to 1590
1600     if(nvel(i,1).le.0) then
           write(14,55) i,xmax
           write(14,55) 0,0.
           write(14,65) 0
           go to 1630
         end if
         nstart=1
1620     j1=nstart
         j2=j1+9
         if(j2.gt.nvel(i,1)) j2=nvel(i,1)
         if(j2.lt.nvel(i,1)) then
           icnt=1
         else
           icnt=0
         end if
         write(14,55) i,(xvel(i,j,1),j=j1,j2)
         write(14,55) icnt,(vf(i,j,1),j=j1,j2)
         write(14,65) (ivarv(i,j,1),j=j1,j2)
         if(j2.eq.nvel(i,1)) go to 1630
         nstart=j2+1
         go to 1620
1630     if(nvel(i,2).le.0) then
           write(14,55) i,xmax
           write(14,55) 0,0.
           write(14,65) 0
           go to 1570
         end if
         nstart=1
1650     j1=nstart
         j2=j1+9
         if(j2.gt.nvel(i,2)) j2=nvel(i,2)
         if(j2.lt.nvel(i,2)) then
           icnt=1
         else
           icnt=0
         end if
         write(14,55) i,(xvel(i,j,2),j=j1,j2)
         write(14,55) icnt,(vf(i,j,2),j=j1,j2)
         write(14,65) (ivarv(i,j,2),j=j1,j2)
         if(j2.eq.nvel(i,2)) go to 1570
         nstart=j2+1
         go to 1650
1570  continue
c
      write(14,55) ncont,(xm(ncont,j),j=1,nzed(ncont))
      write(14,55) 0,(zm(ncont,j),j=1,nzed(ncont))
c
c write out original floating reflectors
c
      if(ifrbnd.eq.1) then
        do 1790 j=1,nfrefl
           write(31,545) npfref(j)
           write(31,565) j,(xfrefl(j,i),i=1,npfref(j))
           write(31,555) (zfrefl(j,i),i=1,npfref(j))
           write(31,575) (ivarf(j,i),i=1,npfref(j))
1790    continue
      end if
c
c calculate layer thickness if held constant
c
      nlyr=0
      do 470 i=2,ncont
         do 480 j=1,nzed(i)
            if(ivarz(i,j).eq.-1) then
              nlyr=nlyr+1
              thick(nlyr)=zm(i,j)-zm(i-1,j)
            end if
480      continue
470   continue
c
c check for fixed velocity gradients
c
      ngrad=0
      do 370 i=1,nlayer
         iflagg=0
         if(nvel(i,2).gt.0) then
           do 380 j=1,nvel(i,2)
              if(ivarv(i,j,2).eq.-1) then
                ngrad=ngrad+1
                xbndc=xvel(i,j,2)
                if(nzed(i).gt.1) then
                  do 390 k=1,nzed(i)-1
                     if(xbndc.ge.xm(i,k).and.xbndc.le.xm(i,k+1))
     +               then
                       zu=(zm(i,k+1)-zm(i,k))*(xbndc-xm(i,k))/
     +                    (xm(i,k+1)-xm(i,k))+zm(i,k)
                       go to 400
                     end if
390               continue
                else
                  zu=zm(i,1)
                end if
400             if(nvel(i,1).gt.0) then
                  vu=vf(i,j,1)
                else
                  do 401 k=i-1,1,-1
                     if(nvel(k,2).gt.0) then
                       vu=vf(k,j,2)
                       go to 402
                     end if
                     if(nvel(k,1).gt.0) then
                       vu=vf(k,j,1)
                       go to 402
                     end if
401               continue
                end if
402             if(nzed(i+1).gt.1) then
                  do 410 k=1,nzed(i+1)-1
                     if(xbndc.ge.xm(i+1,k).and.xbndc.le.xm(i+1,k+1))
     +               then
                       zl=(zm(i+1,k+1)-zm(i+1,k))*(xbndc-xm(i+1,k))/
     +                    (xm(i+1,k+1)-xm(i+1,k))+zm(i+1,k)
                       go to 420
                     end if
410               continue
                else
                  zl=zm(i+1,1)
                end if
420             vl=vf(i,j,2)
                if(abs(vu-vl).gt..001) then
                  if(abs(zl-zu).gt..001) then
                    grad(ngrad)=(vl-vu)/(zl-zu)
                    igrad(ngrad)=1
                  else
                    grad(ngrad)=vl-vu
                    igrad(ngrad)=0
                    iflagg=1
                  end if
                else
                  grad(ngrad)=0.
                  igrad(ngrad)=1
                end if
              end if
380        continue
         end if
c
         if(iflagg.eq.1) then
           write(6,85) i
           write(12,85) i
85         format(/'***  check gradient in layer ',i2,'  ***'/)
         end if
c
370   continue
c
      rewind(13)
c
      write(12,75)
      if(iscrn.eq.1) write(6,75)
75    format(/'velocity model:'/)
c
c check for pinchouts
c
      if(nlayer.gt.1) then
        ipinch=0
        do 281 i=2,nlayer
           do 282 j=1,nzed(i)
              mpinch(i,j,1)=0
              do 283 k=1,i-1
                 do 284 l=1,nzed(k)
                    if(abs(xm(i,j)-xm(k,l)).lt..005.and.
     +                 abs(zm(i,j)-zm(k,l)).lt..005) then
                       ipinch=+1
                       mpinch(i,j,1)=k
                       mpinch(i,j,2)=l
                       go to 282
                    end if
284              continue
283           continue
282        continue
281     continue
      end if
c
c add the parameter adjustments
c
      nvarw=0
      nlyr=0
      do 270 i=1,nlayer
         do 280 j=1,nzed(i)
            if(ipinch.eq.1.and.i.gt.1) then
              if(mpinch(i,j,1).gt.0) then
                zm(i,j)=zm(mpinch(i,j,1),mpinch(i,j,2))
                go to 280
              end if
            end if
            if(ivarz(i,j).gt.0) then
              nvarw=nvarw+1
              zm(i,j)=zm(i,j)+dx(nvarw)
            end if
            if(ivarz(i,j).eq.-1) then
              nlyr=nlyr+1
              zm(i,j)=zm(i-1,j)+thick(nlyr)
            end if
280      continue
c
         if(nvel(i,1).gt.0) then
           do 310 j=1,nvel(i,1)
              if(ivarv(i,j,1).gt.0) then
                nvarw=nvarw+1
                vf(i,j,1)=vf(i,j,1)+dx(nvarw)
              end if
310        continue
         else
           nvel(i,1)=1
           xvel(i,1,1)=xmax
           vf(i,1,1)=0.
         end if
c
         if(nvel(i,2).gt.0) then
           do 430 j=1,nvel(i,2)
              if(ivarv(i,j,2).gt.0) then
                nvarw=nvarw+1
                vf(i,j,2)=vf(i,j,2)+dx(nvarw)
              end if
430        continue
         else
           nvel(i,2)=1
           xvel(i,1,2)=xmax
           vf(i,1,2)=0.
         end if
270   continue
c
      if(ifrbnd.eq.1) then
        do 880 j=1,nfrefl
           do 890 i=1,npfref(j)
              if(ivarf(j,i).eq.1) then
                nvarw=nvarw+1
                zfrefl(j,i)=zfrefl(j,i)+dx(nvarw)
              end if
890        continue
880     continue
      end if
c
c maintain fixed velocity gradients
c
      ngrad=0
      do 271 i=1,nlayer
         do 272 j=1,nvel(i,2)
            if(ivarv(i,j,2).eq.-1) then
              ngrad=ngrad+1
              xbndc=xvel(i,j,2)
              if(nzed(i).gt.1) then
                do 440 k=1,nzed(i)-1
                   if(xbndc.ge.xm(i,k).and.xbndc.le.xm(i,k+1))
     +             then
                     zu=(zm(i,k+1)-zm(i,k))*(xbndc-xm(i,k))/
     +                  (xm(i,k+1)-xm(i,k))+zm(i,k)
                     go to 450
                   end if
440             continue
              else
                zu=zm(i,1)
              end if
450           if(nvel(i,1).gt.0.and.vf(i,1,1).gt.0.) then
                vu=vf(i,j,1)
              else
                do 451 k=i-1,1,-1
                   if(nvel(k,2).gt.0.and.vf(k,1,2).gt.0.) then
                     vu=vf(k,j,2)
                     go to 452
                   end if
                   if(nvel(k,1).gt.0.and.vf(k,1,1).gt.0.) then
                     vu=vf(k,j,1)
                     go to 452
                   end if
451             continue
              end if
              if(igrad(ngrad).eq.1) then
452             if(nzed(i+1).gt.1) then
                  do 460 k=1,nzed(i+1)-1
                     if(xbndc.ge.xm(i+1,k).and.xbndc.le.xm(i+1,k+1))
     +               then
                       zl=(zm(i+1,k+1)-zm(i+1,k))*(xbndc-xm(i+1,k))/
     +                    (xm(i+1,k+1)-xm(i+1,k))+zm(i+1,k)
                       vf(i,j,2)=vu+grad(ngrad)*(zl-zu)
                       go to 272
                     end if
460               continue
                else
                  zl=zm(i+1,1)
                  vf(i,j,2)=vu+grad(ngrad)*(zl-zu)
                end if
              else
                vf(i,j,2)=vu+grad(ngrad)
              end if
            end if
272      continue
271   continue
c
c write out velocity model
c
      do 570 i=1,nlayer
         nstart=1
590      j1=nstart
         j2=j1+9
         if(j2.gt.nzed(i)) j2=nzed(i)
         if(j2.lt.nzed(i)) then
           icnt=1
         else
           icnt=0
         end if
         write(12,55) i,(xm(i,j),j=j1,j2)
         write(12,55) icnt,(zm(i,j),j=j1,j2)
         write(12,65) (ivarz(i,j),j=j1,j2)
         write(13,55) i,(xm(i,j),j=j1,j2)
         write(13,55) icnt,(zm(i,j),j=j1,j2)
         write(13,65) (ivarz(i,j),j=j1,j2)
         if(iscrn.eq.1) then
           write(6,55) i,(xm(i,j),j=j1,j2)
           write(6,55) icnt,(zm(i,j),j=j1,j2)
           write(6,65) (ivarz(i,j),j=j1,j2)
         end if
         if(j2.eq.nzed(i)) go to 600
         nstart=j2+1
         go to 590
600      nstart=1
620      j1=nstart
         j2=j1+9
         if(j2.gt.nvel(i,1)) j2=nvel(i,1)
         if(j2.lt.nvel(i,1)) then
           icnt=1
         else
           icnt=0
         end if
         write(12,55) i,(xvel(i,j,1),j=j1,j2)
         write(12,55) icnt,(vf(i,j,1),j=j1,j2)
         write(12,65) (ivarv(i,j,1),j=j1,j2)
         write(13,55) i,(xvel(i,j,1),j=j1,j2)
         write(13,55) icnt,(vf(i,j,1),j=j1,j2)
         write(13,65) (ivarv(i,j,1),j=j1,j2)
         if(iscrn.eq.1) then
           write(6,55) i,(xvel(i,j,1),j=j1,j2)
           write(6,55) icnt,(vf(i,j,1),j=j1,j2)
           write(6,65) (ivarv(i,j,1),j=j1,j2)
         end if
         if(j2.eq.nvel(i,1)) go to 630
         nstart=j2+1
         go to 620
630      nstart=1
650      j1=nstart
         j2=j1+9
         if(j2.gt.nvel(i,2)) j2=nvel(i,2)
         if(j2.lt.nvel(i,2)) then
           icnt=1
         else
           icnt=0
         end if
         write(12,55) i,(xvel(i,j,2),j=j1,j2)
         write(12,55) icnt,(vf(i,j,2),j=j1,j2)
         write(12,65) (ivarv(i,j,2),j=j1,j2)
         write(13,55) i,(xvel(i,j,2),j=j1,j2)
         write(13,55) icnt,(vf(i,j,2),j=j1,j2)
         write(13,65) (ivarv(i,j,2),j=j1,j2)
         if(iscrn.eq.1) then
           write(6,55) i,(xvel(i,j,2),j=j1,j2)
           write(6,55) icnt,(vf(i,j,2),j=j1,j2)
           write(6,65) (ivarv(i,j,2),j=j1,j2)
         end if
         if(j2.eq.nvel(i,2)) go to 570
         nstart=j2+1
         go to 650
570   continue
c
      write(12,55) ncont,(xm(ncont,j),j=1,nzed(ncont))
      write(12,55) 0,(zm(ncont,j),j=1,nzed(ncont))
      write(13,55) ncont,(xm(ncont,j),j=1,nzed(ncont))
      write(13,55) 0,(zm(ncont,j),j=1,nzed(ncont))
      if(iscrn.eq.1) then
        write(6,55) ncont,(xm(ncont,j),j=1,nzed(ncont))
        write(6,55) 0,(zm(ncont,j),j=1,nzed(ncont))
      end if
c
c write out floating reflectors
c
      if(ifrbnd.eq.1) then
        write(12,175)
        if(iscrn.eq.1) write(6,175)
175     format(/'floating reflectors:'/)
        rewind(30)
        do 790 j=1,nfrefl
           write(30,545) npfref(j)
           write(12,545) npfref(j)
           write(30,565) j,(xfrefl(j,i),i=1,npfref(j))
           write(12,565) j,(xfrefl(j,i),i=1,npfref(j))
565        format(i2,1x,<ppfref>f7.2)
           write(30,555) (zfrefl(j,i),i=1,npfref(j))
           write(12,555) (zfrefl(j,i),i=1,npfref(j))
           write(30,575) (ivarf(j,i),i=1,npfref(j))
           write(12,575) (ivarf(j,i),i=1,npfref(j))
           if(iscrn.eq.1) then
             write(6,545) npfref(j)
             write(6,565) j,(xfrefl(j,i),i=1,npfref(j))
             write(6,555) (zfrefl(j,i),i=1,npfref(j))
             write(6,575) (ivarf(j,i),i=1,npfref(j))
           end if
790     continue
      end if
c
      stop
c
999   write(6,95)
95    format(/'***  error in velocity model  ***'/)
      stop
c
      end
c
c     ----------------------------------------------------------------
c
      subroutine matinv(a,y,n)
c
c     invert the nxn matrix a
c
      include 'rayinvr.par'
c
      real a(pnvar,pnvar),y(pnvar,pnvar)
      integer indx(pnvar)
c
      do 10 i=1,n
         do 20 j=1,n
            y(i,j)=0.
20       continue
         y(i,i)=1.
10    continue
c
      call ludcmp(a,n,indx,d)
c
      do 30 j=1,n
         call lubksb(a,n,indx,y(1,j))
30    continue
c
      return
      end
c
c     ----------------------------------------------------------------
c
      subroutine ludcmp(a,n,indx,d)
c
c     replace a by its LU decomposition
c
      include 'rayinvr.par'
c
      real a(pnvar,pnvar),vv(pnvar)
      integer indx(n)
c
      tiny=1.0e-20
c
      d=1.
      do 10 i=1,n
         aamax=0.
         do 20 j=1,n
            if(abs(a(i,j)).gt.aamax) aamax=abs(a(i,j))
20       continue
         if(aamax.eq.0.) then
           write(6,5)
5          format(/'***  singular matrix  ***'/)
           stop
         end if
         vv(i)=1./aamax
10    continue
      do 30 j=1,n
         if(j.gt.1) then
           do 40 i=1,j-1
              sum=a(i,j)
              if(i.gt.1) then
                do 50 k=1,i-1
                   sum=sum-a(i,k)*a(k,j)
50              continue
                a(i,j)=sum
              end if
40         continue
         end if
         aamax=0.
         do 60 i=j,n
            sum=a(i,j)
            if(j.gt.1) then
              do 70 k=1,j-1
                 sum=sum-a(i,k)*a(k,j)
70            continue
              a(i,j)=sum
            end if
            dum=vv(i)*abs(sum)
            if(dum.ge.aamax) then
              imax=i
              aamax=dum
            end if
60       continue
         if(j.ne.imax) then
           do 80 k=1,n
              dum=a(imax,k)
              a(imax,k)=a(j,k)
              a(j,k)=dum
80         continue
           d=-d
           vv(imax)=vv(j)
         end if
         indx(j)=imax
         if(j.ne.n) then
           if(a(j,j).eq.0.) a(j,j)=tiny
           dum=1./a(j,j)
           do 90 i=j+1,n
              a(i,j)=a(i,j)*dum
90         continue
         end if
30    continue
      if(a(n,n).eq.0.) a(n,n)=tiny
      return
      end
c
c     ----------------------------------------------------------------
c
      subroutine lubksb(a,n,indx,b)
c
c     solve the system of n linear equations ax=b
c
      include 'rayinvr.par'
c
      real a(pnvar,pnvar),b(n)
      integer indx(n)
c
      ii=0
      do 10 i=1,n
         ll=indx(i)
         sum=b(ll)
         b(ll)=b(i)
         if(ii.ne.0) then
           do 20 j=ii,i-1
              sum=sum-a(i,j)*b(j)
20         continue
         else if(sum.ne.0.) then
           ii=i
         end if
         b(i)=sum
10    continue
      do 30 i=n,1,-1
         sum=b(i)
         if(i.lt.n) then
           do 40 j=i+1,n
              sum=sum-a(i,j)*b(j)
40         continue
         end if
         b(i)=sum/a(i,i)
30    continue
      return
      end


      subroutine runP_00iii(i1,i2,i3,m0sq,Gr,Czero3,N0)
      implicit none
      include 'TRconstants.f'
      include 'pvDnames.f'
      include 'pvDv.f'
      include 'Darraydef.f'
      include 'Darrays.f'
      integer ep,N0,i1,i2,i3,m,n,np
      parameter(np=3)
      double precision m0sq,Gr(np,np)
      double complex Czero3(z3max,-2:0),bit,pole

      do ep=-2,0
      bit=czip
      do n=1,np
      do m=1,np
      bit=bit+Gr(n,m)*Dv(diiiii(z5(n,m,i1,i2,i3))+N0,ep)
      enddo
      enddo

      pole=czip
      if (ep .gt. -2) pole=4d0*Dv(dzziii(z3(i1,i2,i3))+N0,ep-1)

      Dv(dzziii(z3(i1,i2,i3))+N0,ep)=
     . (pole
     . +2d0*Czero3(z3(i1,i2,i3),ep)
     . +2d0*m0sq*Dv(diii(z3(i1,i2,i3))+N0,ep)
     . -bit)/20d0
      enddo

      return
      end


      !!=====================================================================================
      !!=====================================================================================
      module parameters
      complex*16,parameter :: ImI    = (0.0d0,1.0d0)
      real*8,parameter     :: PI     = 3.1415926d0
      real*8,parameter     :: WCM    = 0.3d-16                  !! w/cm^2
      real*8,parameter     :: cmi    = 4.556335d-6              !! 1cm^-1 in hartree
      real*8,parameter     :: epc    = 137.0d0/(4.0d0*PI)       !! c*epsilon_0
      real*8,parameter     :: E0     = 0.5d0*sqrt(4d13*WCM/epc)
      real*8,parameter     :: E1     = sqrt(1d3*WCM/epc)
      real*8,parameter     :: E2     = sqrt(0.001d0*WCM/epc)
      real*8,parameter     :: fs     = 1.0d0/0.024d0            !! 1fs in a.u.
      real*8,parameter     :: MASS   = 89380.0d0                !! IBr reduced mass (wolfram)
      real*8,parameter     :: kBT    = 0.0183675d0              !! kB*(5800K) in hartree

      integer,parameter    :: NGRID  = 2100                     !! # of grid points in R
      real*8,parameter     :: dR     = 0.01d0
      real*8,parameter     :: Ri     = 4.0d0
      real*8,parameter     :: TPROP  = 20.0d3*fs                !! 100 points per 1fs
      integer,parameter    :: NPROP  = 2.0d6                    !! note: need 1d6 for 10ps
      real*8,parameter     :: dT     = TPROP/real(NPROP)
      real*8,parameter     :: dOmega = 0.1*cmi

      complex*16,dimension(1:3,1:3,NGRID)   :: W
      complex*16,dimension(NPROP*2+10)      :: field            !! make extra slots for RK4
      real*8,dimension(2000)                :: spectrum
      complex*16,dimension(30,NGRID)        :: eigenstatesB
      real*8,dimension(1:30,1:1000,1:2)     :: coefficientsB

      contains
      !!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
      real*8 function epsilon(t)
      implicit none
      real*8 t
      epsilon = exp(-0.5d0*(t-10d3*fs)**2/(3d3*fs)**2)!/sqrt(sqrt(PI)*3d3*fs)
      !epsilon = 1d0/(exp(-(t-0.25d3*fs)/(0.03d3*fs))+1d0)
      !epsilon = 1d0/(exp(-(8d3*fs-t)/(0.2d3*fs))+1d0)
      end function epsilon
      !!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
      real*8 function s0(omega)
      implicit none
      real*8 omega
      !s0 = (E1/dOmega)*exp(-0.5d0*(omega-17950.0d0*cmi)**2/(30.0d0*cmi)**2)
      s0 = E1*exp(-0.5d0*(omega-17700.0d0*cmi)**2/(300.0d0*cmi)**2)
      !s0 = sqrt(0.0161404d0)*(E1/dOmega)*exp(-0.5d0*(omega-17950.0d0*cmi)**2/(30.0d0*cmi)**2)
      end function s0

      end module parameters
      !!=====================================================================================
      !!=====================================================================================

      !!====================================================================
      !!   Gaussian random number generator
      !!   "call random_seed()" before calling this subroutine.
      !!====================================================================
      subroutine G_RNG(mean,sigma,output)
      implicit none
      real*8  mean,sigma,gauss,output,var(1:2)

      do
       call random_number(var)
       var(1) = 4.0d0*sigma*(2.0d0*var(1)-1.0d0)
       gauss = exp(-0.5d0*(mean+var(1))**2/(sigma**2))
       if(var(2).le.gauss)then
         exit
       endif
      enddo

      output = var(1)
      end subroutine

 	!!====================================================================
	!!   Doppler spectral amplitude random variable generator
      !!   "call random_seed()" before calling this subroutine.
      !!====================================================================
 	subroutine D_RNG(mean,output)
      use parameters
      implicit none
      real*8  mean,pdf,output,var(1:2)

      do
       call random_number(var)
       var(1) = var(1)*4d0*mean
	 var(2) = var(2)*sqrt(PI/2d0)*exp(-0.5d0)/mean
       pdf = 2d0*var(1)*PI/(4d0*mean**2) * exp(-var(1)**2*PI/(4d0*mean**2))
       if(var(2).le.pdf)then
         exit
       endif
      enddo

      output = var(1)
      end subroutine

	!!====================================================================
	!!   collision phase-jump time random variable generator
      !!   "call random_seed()" before calling this subroutine.
      !!====================================================================
	subroutine C_RNG(mean,output)
      use parameters
      implicit none
      real*8  mean,pdf,output,var(1:2)

      do
       call random_number(var)
       var(1) = var(1)*10d0*mean
	 var(2) = var(2)/mean
       pdf = exp(-var(1)/mean)/mean
       if(var(2).le.pdf)then
         exit
       endif
      enddo

      output = var(1)
      end subroutine

	!!====================================================================
      !!   make collision broadened field
      !!====================================================================
	subroutine make_c_field(tauc,omega)
      use parameters
      implicit none
	integer Nemitter,i,j,k
	real*8 tauc,omega,tickers(10000),angles(10000),time,temp

	field    = 0.0d0
	Nemitter = 1000

	call random_seed()
	do j=1,Nemitter
 	 call C_RNG(tauc,tickers(j))
	enddo
	call random_number(angles)
	angles = 2d0*PI*angles

      do i=1,size(field)
	 field(i) = 0.0d0
       time     = real(i)*dT/2.0d0
	 do j=1,Nemitter
	   if(time.ge.tickers(j))then
	     call C_RNG(tauc,temp)
	     tickers(j) = tickers(j) + temp
	     call random_number(angles(j))
	     angles(j) = 2d0*PI*angles(j)
	   endif
	   field(i) = field(i) + exp(ImI*angles(j))
	 enddo
	 field(i) = E2*epsilon(time)*field(i)*exp(-ImI*omega*time)
	 !field(i) = E2*field(i)*exp(-ImI*omega*time)
	enddo

	end subroutine

      !!====================================================================
      !!   phase-shaped (solar) field (deterministic power spectrum)
      !!====================================================================
      subroutine make_ps_field(signal,iteration)
      use parameters
      implicit none
      integer i,j,iteration
      real*8 signal,omega,time,phases(1d5)
      complex*16 efield

      field = 0.0d0
      call random_seed()
      call random_number(phases)
      phases = signal*2.0d0*PI*phases
      !do i=1,size(phases)
      !  call G_RNG(0d0,signal*PI,phases(i))
      !enddo

      do i=1,size(field)
       time = real(i)*dT/2.0d0
       do j=16400,18400
         omega  = real(j)*cmi
         !efield = (omega**3/(4d0*PI**3*137d0**2))/(exp(omega/kBT)-1d0)
         !efield = sqrt(1d0*cmi*efield/epc)
         !efield = efield * exp(-ImI*(omega*(time-2d3*fs)+phases(j)))
         efield = s0(omega)*exp(-ImI*(omega*(time-2d3*fs)+phases(j)))
         field(i) = field(i) + efield
       enddo

       if(mod(i,size(field)/10)==0.0d0)then
         print *, 100*i/size(field),"% done"
       endif

       field(i) = field(i)*epsilon(time)
      enddo
      end subroutine

      !!====================================================================
      !!   Calculates the power spectrum from the field autocorrelation
      !!====================================================================

      subroutine powerspec(null)
      use parameters
      implicit none
      integer null,i,j,k
      real*8 delay
      complex*16 integral,autocorr(-1000:1000)

      do i=-1000,1000
        delay    = real(i)*0.01d0*fs
        k        = delay/(dT/2d0)
        integral = 0.0d0
        do j=abs(k),size(field)-abs(k)
          integral = integral + conjg(field(j))*field(j+k)
        enddo
      enddo

      end subroutine

      !!====================================================================
      !!   Calculate the power spectrum from Fourier transform,
      !!   and add to the "spectrum" array for further averaging
      !!====================================================================
      subroutine add_to_spectrum(null)
      use parameters
      implicit none
      integer null,j,k
      real*8 E
      complex*16 fourier

      do j=1,500!200
        !E = (real(j)*0.1d0 + 17854.0d0)*cmi
        E = real(j)*100d0*cmi
        fourier = 0.0d0
        do k=1,size(field)
          fourier = fourier + field(k)*exp(ImI*E*real(k)*dT/2d0)
        enddo
        spectrum(j) = spectrum(j) + (abs(fourier)*dT/2d0)**2

        !if(mod(j,200)==0.0d0)then
        !  print *,j/20,"% spectrum done"
        !endif
      enddo

      end subroutine
      !!====================================================================
      !!   Calculates the overlap to B manifold eigenstates
      !!====================================================================
	subroutine readin_eigenstates(null)
      use parameters
      implicit none
	integer i,j,null
	real*8 dummy

	open(123,FILE="input/eigenvectors-B.txt")
	do i=1,NGRID
	  read(123,*) dummy, (eigenstatesB(j,i),j=1,27)
	enddo
	close(123)

	coefficientsB = 0.0d0

	end subroutine
	!! -------------------------------------------------------------
	subroutine project_to_B(WP,k)
      use parameters
      implicit none
	complex*16 WP(1:3,NGRID),integral
	integer i,j,k

	do i=1,27
	  integral = 0.0d0
	  do j=1,1000
	    integral = integral + eigenstatesB(i,j)*WP(3,j)
	  enddo
        integral = integral*dR
	  coefficientsB(i,k,1) = coefficientsB(i,k,1) + abs(integral)**2
	  coefficientsB(i,k,2) = coefficientsB(i,k,2) + atan2(aimag(integral),real(integral))
	enddo

	end subroutine


      double complex function aqqb_wbb(i1,i2,i5,i6,i3,i4)
      implicit none
C---This is the amplitude for
C---q_L(p1)+q_L(p6) --> q_L(p2)+q_L(p5)+W(l(p3)+antilepton(p4))
c---with no couplings included
      include 'constants.f'
      include 'masses.f'
C---'prods.f' includes both the declaration and the common for s and za,zb
      include 'sprods_com.f'
      include 'zprods_com.f'
      integer i1,i2,i3,i4,i5,i6
      double complex t2
      double precision s234,s256,prop
      s234=s(i2,i3)+s(i2,i4)+s(i3,i4)
      s256=s(i2,i6)+s(i2,i5)+s(i5,i6)
      prop=s(i5,i6)*dsqrt((s(i3,i4)-wmass**2)**2+(wmass*wwidth)**2)
      aqqb_wbb=
     & +za(i3,i2)*zb(i6,i1)*t2(i4,i2,i3,i5)/(prop*s234)
     & +za(i5,i2)*zb(i4,i1)*t2(i6,i2,i5,i3)/(prop*s256)
      return
      end


*     MB04AZ EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER            NIN, NOUT
      PARAMETER          ( NIN = 5, NOUT = 6 )
      INTEGER            NMAX
      PARAMETER          ( NMAX = 50 )
      INTEGER            LDB, LDC, LDD, LDFG, LDQ, LDU, LDWORK, LDZ,
     $                   LIWORK, LZWORK
      PARAMETER          ( LDB = NMAX,  LDC =   NMAX, LDD = NMAX,
     $                     LDFG = NMAX, LDQ = 2*NMAX, LDU = NMAX,
     $                     LDWORK = 18*NMAX*NMAX + NMAX + MAX( 2*NMAX,
     $                                                         24 ) + 3,
     $                     LDZ = NMAX, LIWORK = 2*NMAX + 9,
     $                     LZWORK = 8*NMAX + 28 )
*
*     .. Local Scalars ..
      CHARACTER          COMPQ, COMPU, JOB
      INTEGER            I, INFO, J, M, N
*
*     .. Local Arrays ..
      COMPLEX*16         B( LDB,   NMAX ),  C( LDC,   NMAX ),
     $                   D( LDD,   NMAX ), FG( LDFG,  NMAX ),
     $                   Q( LDQ, 2*NMAX ),  U( LDU, 2*NMAX ),
     $                   Z( LDZ,   NMAX ), ZWORK( LZWORK )
      DOUBLE PRECISION   ALPHAI( NMAX ), ALPHAR( NMAX ),
     $                   BETA(   NMAX ), DWORK(LDWORK )
      INTEGER            IWORK( LIWORK )
      LOGICAL            BWORK( NMAX )
*
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*
*     .. External Subroutines ..
      EXTERNAL           MB04AZ
*
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MOD
*
*     .. Executable Statements ..
*
      WRITE( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read in the data.
      READ( NIN, FMT = * )
      READ( NIN, FMT = * ) JOB, COMPQ, COMPU, N
      IF( N.LT.0 .OR. N.GT.NMAX .OR. MOD( N, 2 ).NE.0 ) THEN
         WRITE( NOUT, FMT = 99998 ) N
      ELSE
         READ( NIN, FMT = * ) ( (  Z( I, J ), J = 1, N ),     I=1, N )
         READ( NIN, FMT = * ) ( (  B( I, J ), J = 1, N/2 ),   I=1, N/2 )
         READ( NIN, FMT = * ) ( ( FG( I, J ), J = 1, N/2+1 ), I=1, N/2 )
*        Compute the eigenvalues of a complex skew-Hamiltonian/
*        Hamiltonian pencil (factored version).
         CALL MB04AZ( JOB, COMPQ, COMPU, N, Z, LDZ, B, LDB, FG, LDFG,
     $                D, LDD, C, LDC, Q, LDQ, U, LDU, ALPHAR, ALPHAI,
     $                BETA, IWORK, LIWORK, DWORK, LDWORK, ZWORK, LZWORK,
     $                BWORK, INFO )
*
         IF( INFO.NE.0 ) THEN
            WRITE( NOUT, FMT = 99997 ) INFO
         ELSE
            M = N/2
            IF( LSAME( JOB, 'T' ) ) THEN
               WRITE( NOUT, FMT = 99996 )
               DO 10 I = 1, N
                  WRITE( NOUT, FMT = 99995 ) (  Z( I, J ), J = 1, N )
   10          CONTINUE
               WRITE( NOUT, FMT = 99994 )
               DO 20 I = 1, N
                  WRITE( NOUT, FMT = 99995 ) (  B( I, J ), J = 1, N )
   20          CONTINUE
               WRITE( NOUT, FMT = 99993 )
               DO 30 I = 1, N
                  WRITE( NOUT, FMT = 99995 ) ( FG( I, J ), J = 1, N )
   30          CONTINUE
               WRITE( NOUT, FMT = 99992 )
               DO 40 I = 1, N
                  WRITE( NOUT, FMT = 99995 ) (  D( I, J ), J = 1, N )
   40          CONTINUE
               WRITE( NOUT, FMT = 99991 )
               DO 50 I = 1, N
                  WRITE( NOUT, FMT = 99995 ) (  C( I, J ), J = 1, N )
   50          CONTINUE
            END IF
            IF( LSAME( COMPQ, 'C' ) ) THEN
               WRITE( NOUT, FMT = 99990 )
               DO 60 I = 1, 2*N
                  WRITE( NOUT, FMT = 99995 ) ( Q( I, J ), J = 1, 2*N )
   60          CONTINUE
            END IF
            IF( LSAME( COMPU, 'C' ) ) THEN
               WRITE( NOUT, FMT = 99989 )
               DO 70 I = 1, N
                  WRITE( NOUT, FMT = 99995 ) ( U( I, J ), J = 1, 2*N )
   70          CONTINUE
            END IF
            WRITE( NOUT, FMT = 99988 )
            WRITE( NOUT, FMT = 99987 ) ( ALPHAR( I ), I = 1, N )
            WRITE( NOUT, FMT = 99986 )
            WRITE( NOUT, FMT = 99987 ) ( ALPHAI( I ), I = 1, N )
            WRITE( NOUT, FMT = 99985 )
            WRITE( NOUT, FMT = 99987 ) (   BETA( I ), I = 1, N )
         END IF
      END IF
      STOP
*
99999 FORMAT ( 'MB04AZ EXAMPLE PROGRAM RESULTS', 1X )
99998 FORMAT ( 'N is out of range.', /, 'N = ', I5 )
99997 FORMAT ( 'INFO on exit from MB04AZ = ', I2 )
99996 FORMAT (/' The transformed matrix Z is' )
99995 FORMAT (20(1X,F9.4,SP,F9.4,S,'i '))
99994 FORMAT (/' The transformed matrix B is' )
99993 FORMAT (/' The transformed matrix FG is' )
99992 FORMAT (/' The matrix D is' )
99991 FORMAT (/' The matrix C is' )
99990 FORMAT (/' The matrix Q is' )
99989 FORMAT (/' The upper part of the matrix U is' )
99988 FORMAT (/' The vector ALPHAR is ' )
99987 FORMAT ( 50( 1X, F8.4 ) )
99986 FORMAT (/' The vector ALPHAI is ' )
99985 FORMAT (/' The vector BETA is ' )
      END


module core_lib

  use posix, only : microsleep

  ! Configuration file I/O
  use lib_conf
  use lib_io
  use lib_version

  ! Error/message handling
  use lib_messages

  ! Basic numeric types
  use base_types

  ! Maths
  use lib_constants
  use lib_algebra
  use lib_statistics
  use type_pdf
  use type_angle3d
  use type_vector3d
  use type_stokes
  use lib_array
  use lib_random

  ! External
  use lib_hdf5

end module core_lib


*     SB10ZD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          MMAX, NMAX, PMAX
      PARAMETER        ( MMAX = 10, NMAX = 10, PMAX = 10 )
      INTEGER          LDA, LDAK, LDB, LDBK, LDC, LDCK, LDD, LDDK
      PARAMETER        ( LDA  = NMAX, LDAK = NMAX, LDB  = NMAX,
     $                   LDBK = NMAX, LDC  = PMAX, LDCK = MMAX,
     $                   LDD  = PMAX, LDDK = MMAX )
      INTEGER          LIWORK
      PARAMETER        ( LIWORK = 2*MAX( NMAX, MMAX + PMAX ) )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = 16*NMAX*NMAX + 5*MMAX*MMAX +
     $                            7*PMAX*PMAX + 6*MMAX*NMAX +
     $                            7*MMAX*PMAX + 7*NMAX*PMAX + 6*NMAX +
     $                            2*( MMAX + PMAX ) +
     $                            MAX( 14*NMAX + 23, 16*NMAX,
     $                                  2*MMAX - 1, 2*PMAX - 1 ) )
*     .. Local Scalars ..
      DOUBLE PRECISION FACTOR, TOL
      INTEGER          I, INFO, J, M, N, NP
*     .. Local Arrays ..
      LOGICAL          BWORK(2*NMAX)
      INTEGER          IWORK(LIWORK)
      DOUBLE PRECISION A(LDA,NMAX),   AK(LDAK,NMAX), B(LDB,MMAX),
     $                 BK(LDBK,PMAX), C(LDC,NMAX),   CK(LDCK,NMAX),
     $                 D(LDD,MMAX),   DK(LDDK,PMAX), DWORK(LDWORK),
     $                 RCOND( 6 )
*     .. External Subroutines ..
      EXTERNAL         SB10ZD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, NP
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99990 ) N
      ELSE IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
         WRITE ( NOUT, FMT = 99989 ) M
      ELSE IF ( NP.LT.0 .OR. NP.GT.PMAX ) THEN
         WRITE ( NOUT, FMT = 99988 ) NP
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N )
         READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,NP )
         READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,NP )
         READ ( NIN, FMT = * ) FACTOR, TOL
         CALL SB10ZD( N, M, NP, A, LDA, B, LDB, C, LDC, D, LDD, FACTOR,
     $                AK, LDAK, BK, LDBK, CK, LDCK, DK, LDDK, RCOND,
     $                TOL, IWORK, DWORK, LDWORK, BWORK, INFO )
         IF ( INFO.EQ.0 ) THEN
            WRITE ( NOUT, FMT = 99997 )
            DO 10 I = 1, N
               WRITE ( NOUT, FMT = 99992 ) ( AK(I,J), J = 1,N )
   10       CONTINUE
            WRITE ( NOUT, FMT = 99996 )
            DO 20 I = 1, N
               WRITE ( NOUT, FMT = 99992 ) ( BK(I,J), J = 1,NP )
   20       CONTINUE
            WRITE ( NOUT, FMT = 99995 )
            DO 30 I = 1, M
               WRITE ( NOUT, FMT = 99992 ) ( CK(I,J), J = 1,N )
   30       CONTINUE
            WRITE ( NOUT, FMT = 99994 )
            DO 40 I = 1, M
               WRITE ( NOUT, FMT = 99992 ) ( DK(I,J), J = 1,NP )
   40       CONTINUE
            WRITE( NOUT, FMT = 99993 )
            WRITE( NOUT, FMT = 99991 ) ( RCOND(I), I = 1,6 )
         ELSE
            WRITE( NOUT, FMT = 99998 ) INFO
         END IF
      END IF
      STOP
*
99999 FORMAT (' SB10ZD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (/' INFO on exit from SB10ZD =',I2)
99997 FORMAT (/' The controller state matrix AK is'/)
99996 FORMAT (/' The controller input matrix BK is'/)
99995 FORMAT (/' The controller output matrix CK is'/)
99994 FORMAT (/' The controller matrix DK is'/)
99993 FORMAT (/' The estimated condition numbers are'/)
99992 FORMAT (10(1X,F8.4))
99991 FORMAT ( 5(1X,D12.5))
99990 FORMAT (/' N is out of range.',/' N = ',I5)
99989 FORMAT (/' M is out of range.',/' M = ',I5)
99988 FORMAT (/' NP is out of range.',/' NP = ',I5)
      END


*
*     -------------------------------------------------------------
*      N I N E S S
*     -------------------------------------------------------------
*                                                                  *
*    THIS PACKAGE DETERMINES THE VALUES OF 9j COEFFICIENT          *
*                                                                  *
*     |  1/2  1/2  J1  |                                           *
*     |  1/2  1/2  J2  |                                           *
*     |  J3   J4   J5  |                                           *
*                                                                  *
*                                                                  *
*     Written by G. Gaigalas,                                      *
*     Vanderbilt University,  Nashville               October 1996 *
*
      SUBROUTINE NINESS(J1,J2,J3,J4,J5,A)
      IMPLICIT DOUBLEPRECISION (A-H,O-Z)
      DIMENSION IS(2,2,2,2,3),IV(2,2,2,2,3)
      DATA IS/1,2*0,1,8*0,1,2*0,-1,5*0,1,-1,1,0,-1,2*1,
     :0,2*1,16*0,1/
      DATA IV/4,2*1,12,8*1,12,2*1,324,5*1,2*36,54,1,2*36,54,1,
     :2*54,16*1,81/
      K1=J1+1
      K2=J2+1
      K3=J3+1
      K4=J4+1
      K5=J5+1
      A=DBLE(IS(K1,K2,K3,K4,K5))/DSQRT(DBLE(IV(K1,K2,K3,K4,K5)))
      RETURN
      END


module sym

  use precision, only: ip, sp, dp
  use test_vars, only: fmt_test_name, fmt_test_res

  use tridiag, only: tridiag_sym
  use tridiag_matmul, only: tridiag_matmul_sym

  implicit none

  real(sp) :: dev_sp
  real(dp) :: dev_dp

contains

  subroutine sym_tests()

    write(*, fmt_test_name, advance="no") "sym"

    dev_dp = sym_real_dp()
    write(*, fmt_test_res, advance="no") dev_dp

    dev_sp = sym_real_sp()
    write(*, fmt_test_res, advance="no") dev_sp

    dev_dp = sym_cmplx_dp()
    write(*, fmt_test_res, advance="no") dev_dp

    dev_sp = sym_cmplx_sp()
    write(*, fmt_test_res, advance="no") dev_sp

    write(*,*)

  end subroutine sym_tests

  real(dp) function sym_real_dp() result(val)
    integer(ip), parameter :: fp = dp

    include "./sym_src/real.src"
  end function sym_real_dp

  real(dp) function sym_cmplx_dp() result(val)
    integer(ip), parameter :: fp = dp

    include "./sym_src/cmplx.src"
  end function sym_cmplx_dp

  real(sp) function sym_real_sp() result(val)
    integer(ip), parameter :: fp = sp

    include "./sym_src/real.src"
  end function sym_real_sp

  real(sp) function sym_cmplx_sp() result(val)
    integer(ip), parameter :: fp = sp

    include "./sym_src/cmplx.src"
  end function sym_cmplx_sp

end module sym


      COMPLEX FUNCTION CDOTC(N,CX,INCX,CY,INCY)

      INTEGER            INCX, INCY, N
      REAL               CX( * ), CY( * )

      COMPLEX            CTEMP
      EXTERNAL           CDOTC_SUB

      CALL CDOTC_SUB( N, CX, INCX, CY, INCY, CTEMP )
      CDOTC = CTEMP

      RETURN
      END


!!# MODULE <<TBX_SMlib>>
MODULE TBX_SMlib

!!## PURPOSE
!! Contains all the SMlib modules in one place.

USE USR_SMlib_Flop               !!((16-B-USR_SMlib_Flop.f90))
USE USR_SMlib_IO                 !!((16-B-USR_SMlib_IO.f90))
USE USR_SMlib_Precision          !!((16-B-USR_SMlib_Precision.f90))
USE USR_SMlib_Band_LU            !!((17-B-USR_SMlib_Band_LU.f90))
USE USR_SMlib_CSR                !!((17-B-USR_SMlib_CSR.f90))
USE USR_SMlib_Iteration_Defaults !!((17-B-USR_SMlib_Iteration_Defaults.f90))
USE USR_SMlib_Misc               !!((17-B-USR_SMlib_Misc.f90))
USE USR_SMlib_MSR                !!((17-B-USR_SMlib_MSR.f90))
USE USR_SMlib_LU_CSR_MSR         !!((18-B-USR_SMlib_LU_CSR_MSR.f90))
USE USR_SMlib_Matrix_Arithmetic  !!((19-B-USR_SMlib_Matrix_Arithmetic.f90))
USE USR_SMlib_Band_Gauss_Solver  !!((20-B-USR_SMlib_Band_Gauss_Solver.f90))
USE USR_SMlib_BiCGSTAB           !!((20-B-USR_SMlib_BiCGSTAB.f90))
USE USR_SMlib_CGS                !!((20-B-USR_SMlib_CGS.f90))
USE USR_SMlib_GMRES              !!((20-B-USR_SMlib_GMRES.f90))
USE USR_SMlib_ILU                !!((20-B-USR_SMlib_ILU.f90))

END MODULE


      subroutine bcoef(kinit, ipol, ptz, le2, ltrace, ispin, angks,
     1                 kind, lind, bmat)
c     written by alexei ankudinov; march 2000
c     calculate bmat: the energy independent sum over polarization and
c     angular momenta indices
c     bmat = \sum_{p,p', all m_j} <LS|J><J|R|J1><J1|\alpha_p exp(i kz)|I>
c                    ptz(p,p')
c            <I|\alpha_p'^* exp(-i kz) J2><J2|R'|J'><J'|L'S'>
c     where R is rotation from spin vector to x-ray k-vector
c     and R' is rotation back
c     see Eq.10 and 11 in Ankudinov,Rehr, Phys.Rev.B (accepted),
c     Theory of solid state contribution to the x-ray elastic scattering
c     aditional rotation matrices are needed when x-ray k-vector
c     is not along the spin-axis (see rotations in rdinp)

c     more precisely it is
c     bmat(l1 l1' j l ml ms; l2 l2' j' l' ml' ms') =
c        (-)**(j-j'+l2'+1) i**(l'-l) \sum_{p,p',mi,m1,mj,m2,mj'}
c        <LS|J>   r^j_{m1,mj}(angks)   3j( j l1 i ; -m1 p mi)
c        (-p)**(l1+l1'+1) ptz(p,p') (-p')**(l2+l2'+1)
c        3j( j' l2 i ; -m2  p' mi)   r^j'_{m2,mj'}(angks)   <J'|L'S'>
c     where l1 l1' are set by the multipole moment(E1-l1=1,l1'=0;
c     E2-l1=2,l1'=1; M1-l1=1,l1'=1; etc.;
c     j and l define quantum number kappa and for each multipole moment
c     Only few final kappa's are allowed and  it is convinient
c     to denote (l1 l1' j l) by one index 'k'
c     thus  k=1-8 to include both E1 and E2 transitions;
c     ml and ms are projections of orbital and spin moments.

c     bmat  is used to calculate absorption fine structure (chi) via
c       chi = \sum_{k ms,k' ms'}  rkk(k,ms)  rkk(k',ms')
c       \sum_{ml,ml'}  bmat(k ml ms; k' ml' ms')  G_(l' ml' ms';l ml ms)
c     where sum over spins can be moved from first sum to second for
c     spin independent systems. The above expression is suitable for FMS
c     and for MS expansion on can use Eq.15 in RA paper to obtain
c     expression for the termination   matrix
c     T_{lam1 ms,lamN ms'} = \sum_{k k'} rkk(k,ms) rkk(k',ms')
c       \sum_{ml,ml'}  bmat(k ml ms; k' ml' ms') gam(l,lam1,rho1,ms)
c        gamtl(l',lamN,rhoN,ms')
c     Notice that for spin-dependent systems the scattering F matrices
c     in RA paper also should have additional spin indices. In genfmt
c     we currently neglect spin-flip processes which simplifies
c     calculations with MS expansion. (T and F are diagonal in ms,ms')

c     This subroutine is written for general spin-dependent asymmetric
c     system and arbitrary polarization tenzor. The symmetry of the
c     system and polarization tenzor can be used
c     to speed up FMS or MS calculations in appropriate subroutines.
c     (see comments in subroutines mpprmp, fmstot)

c     input:
c       kinit - kappa for initial orbital
c       ipol - polarization type measurement
c       ptz  - polarization tensor (needed only for ipol=1 case)
c       le2  - sets which multipole moments to include (see mkptz)
c       ltrace- .true. for xsect.f, where need to perform trace over ml
c       angks - angle between k-vector and spin-vector

c     output
c       lind  - orb.mom.(kappa)  needed in fmstot only (for indexing)
c       bmat  - energy independent matrix to calculate absorption
c       in many cases bmat is diagonal due to the choice of xyz frame,
c       but for general case full 16*(2*lx+1)*16*(2*lx+1) matrix is kept

      implicit double precision (a-h,o-z)
      include '../HEADERS/dim.h'
      complex*16 coni
      parameter (coni = (0,1))

c     need only parameter lx to set max orb momentum
      complex*16 ptz, bmat, pmat, tmat
      dimension ptz(-1:1,-1:1),  bmat(-lx:lx,0:1,8, -lx:lx,0:1,8)
c       to include all possible dipole and quadrupole transitions
c       final kp, and kpp have 8 possibilities
      logical ltrace

c     local staff
      dimension  t3j( 8, 0:1, -lx:lx+1), x3j(8, -1:1, -lx:lx+1)
c     qmat = <J2|R'|J'><J'|L'S'> - diagonal in kappa index
      dimension qmat( -lx:lx+1, -lx:lx, 0:1, 8)
c     pmat = <J1|\alpha_j exp(i kz)|I> ptz <I|\alpha_k^* exp(-i kz)|J2>
      dimension pmat( -lx:lx+1, 8, -lx:lx+1, 8)
c     tmat = pmat*qmat ; bmat = qmat^T*tmat
      dimension tmat( -lx:lx+1, 8, -lx:lx, 0:1, 8)
c     total and orbital momenta for 8 possible final kappa
      dimension jind(8), lind(8), kind(8)

      external cwig3j

      do 10 i6 = 1, 8
      do 10 i5 = 0 ,1
      do 10 i4 = -lx,lx
      do 10 i3 = 1, 8
      do 10 i2 = 0 ,1
      do 10 i1 = -lx,lx
         bmat( i1, i2, i3, i4, i5, i6) = 0
  10  continue

c     3 dipole transitions
      do 20 k=-1,1
         kap=kinit+k
         if (k.eq.0) kap=-kap
         jkap = abs(kap)
         lkap = kap
         if (kap.le.0) lkap = abs(kap) -1
c        check that orbital momentum does not exceed max allowed
         if (lkap .gt. lx) then
c          set final j and l to unphysical values
           jkap = 0
           lkap = -1
           kap = 0
         endif
         jind(k+2) = jkap
         lind(k+2) = lkap
         kind(k+2) = kap
  20  continue

c     include 5 quadrupole or 3 mag.dipole  transitions
      do 120 k=-2,2
         jkap = abs(kinit) + k
         if (jkap.le.0) jkap = 0
         kap= jkap
         if (kinit.lt.0 .and. abs(k).ne.1) kap=-jkap
         if (kinit.gt.0 .and. abs(k).eq.1) kap=-jkap
         lkap = kap
         if(kap.le.0) lkap = - kap - 1
         if (lkap.gt.lx .or. le2.eq.0
     1                  .or. (le2.eq.1 .and. abs(k).eq.2)) then
c           set unphysical jkap and lkap to make shorter calculations
            jkap = 0
            lkap = -1
            kap = 0
         endif
         jind(k+6) = jkap
         lind(k+6) = lkap
         kind(k+6) = kap
 120  continue

      if (ipol.eq.0) then
c       polarization average case; bmat is diagonal and simple
        do 100 k = 1, 8
        do 100 ms = 0 ,1
        do 100 ml = -lind(k), lind(k)
c         i2 = (2*l1+1) , where l1 is defined by multipole moment
          i2 = 3
          if (le2.eq.2 .and. k.gt.3) i2 = 5
          bmat(ml,ms,k, ml,ms,k) = 0.5d0 / (2*lind(k)+1.d0) / i2
          if (k.le.3) bmat(ml,ms,k, ml,ms,k) = - bmat(ml,ms,k, ml,ms,k)
 100    continue
      else
c       more complicated bmat for linear(ipol=1) and circular(ipol=2)
c       polarizations
c       Put 3j factors in x3j and t3j. t3j are multiplied by
c       sqrt(2*j'+1) for  further convinience.
        do 30  mp=-lx,lx+1
        do 30  ms=0,1
        do 30  k1=1,8
  30    t3j(k1,ms,mp) = 0.0d0
        do 40  mp=-lx,lx+1
        do 40  ms=-1,1
        do 40  k1=1,8
  40      x3j(k1,ms,mp) = 0.0d0

        do 70  k1 = 1,8
        do 70  mp = -jind(k1)+1,jind(k1)
          do 50 ms=0,1
            j1 = 2 * lind(k1)
            j2 = 1
            j3 = 2 * jind(k1) - 1
            m1 = 2*(mp-ms)
            m2 = 2*ms - 1
            t3j(k1,ms,mp)=sqrt(j3+1.0d0) * cwig3j(j1,j2,j3,m1,m2,2)
            if (mod( (j2-j1-m1-m2)/2 , 2) .ne.0)
     1          t3j(k1,ms,mp) = - t3j(k1,ms,mp)
c           t3j(m0,i)    are Clebsch-Gordon coefficients
  50      continue
          do 60 i=-1,1
            j1 = 2 * jind(k1) - 1
            j2 = 2
            if (k1.gt.3 .and. le2.eq.2) j2 = 4
            j3 = 2 * abs(kinit) - 1
            m1 = -2*mp + 1
            m2 = 2*i
            x3j(k1,i,mp)= cwig3j(j1,j2,j3,m1,m2,2)
  60      continue
  70    continue

c       calculate qmat
        do 220 i=1,8
        do 220 ms=0,1
        do 220 ml= -lind(i), lind(i)
        do 220 mj= -jind(i)+1, jind(i)
          mp = ml+ms
          jj = 2*jind(i) - 1
          mmj = 2*mj - 1
          mmp = 2*mp - 1
          value = rotwig(angks, jj, mmj, mmp, 2)
          qmat(mj,ml,ms,i) = value * t3j(i,ms,mp)
 220    continue

c       calculate pmat
        do 240 i2 = 1,8
        do 240 m2 = -jind(i2)+1, jind(i2)
        do 240 i1 = 1,8
        do 240 m1 = -jind(i1)+1, jind(i1)
          pmat(m1,i1,m2,i2) = 0
          if (abs(m2-m1).le.2) then
            do 230 j=-1,1
            do 230 i=-1,1
c             check that initial moment is the same
              if (m1-i.eq.m2-j) then
                is = 1
c               (-p) factors for M1 transitions
                if (le2.eq.1 .and. i.gt.0 .and. i1.gt.3) is = -is
                if (le2.eq.1 .and. j.gt.0 .and. i2.gt.3) is = -is
                pmat(m1,i1,m2,i2) = pmat(m1,i1,m2,i2) +
     1          is * x3j(i1,i,m1) * ptz(i,j) * x3j(i2,j,m2)
              endif
 230        continue
c           multiply by (-)^(j-j'+l2'+1) i**(l'-l) factor
c           additional (-) is from Eq.10 (-2*ck)
            is = 1
            if (mod(jind(i1)-jind(i2), 2) .ne.0) is = -is
            if (i2.le.3) is = -is
            pmat(m1,i1,m2,i2) = pmat(m1,i1,m2,i2) * is
     1           * coni**(lind(i2)-lind(i1))
          endif
 240    continue

c       calculate tmat = pmat*qmat
        do 270 i1=1,8
        do 270 ms=0,1
        do 270 ml=-lind(i1), lind(i1)
        do 270 i2=1,8
        do 270 mj=-jind(i2)+1, jind(i2)
          tmat(mj,i2, ml,ms,i1) = 0
          do 260 mp = -jind(i1)+1, jind(i1)
            tmat(mj,i2, ml,ms,i1) = tmat(mj,i2, ml,ms,i1)+
     1           pmat(mj,i2,mp,i1) * qmat(mp,ml,ms,i1)
 260      continue
 270    continue

c       calculate bmat = qmat^T * tmat
        do 300 i1=1,8
        do 300 ms1=0,1
        do 300 ml1=-lind(i1), lind(i1)
        do 300 i2=1,8
        do 300 ms2=0,1
        do 300 ml2=-lind(i2), lind(i2)
          bmat(ml2,ms2,i2, ml1,ms1,i1) = 0
          do 280 mj=-jind(i2)+1, jind(i2)
            bmat(ml2,ms2,i2, ml1,ms1,i1) = bmat(ml2,ms2,i2, ml1,ms1,i1)+
     1      qmat(mj,ml2,ms2,i2) * tmat(mj,i2,ml1,ms1,i1)
 280      continue
 300    continue
c       end of ipol=1,2 cases
      endif

      if (ltrace) then
c       need to trace bmat over ml for xsect.f
        do 390 i1 = 1, 8
        do 390 ms1 = 0,1
        do 390 i2 = 1, 8
        do 390 ms2 = 0,1
          if (lind(i1).ne.lind(i2) .or. ms1.ne.ms2) then
               bmat(0,ms2,i2, 0,ms1,i1) = 0
          else
             do 360 ml = 1, lind(i1)
               bmat(0,ms1,i2, 0,ms1,i1) =  bmat(0,ms1,i2, 0,ms1,i1) +
     1         bmat(-ml,ms1,i2, -ml,ms1,i1) + bmat(ml,ms1,i2, ml,ms1,i1)
 360         continue
          endif
 390    continue
      endif

      if (ispin .eq. 0) then
c       G(Ls,L's') is spin diagonal; trace over spin
        do 480 i1 = 1, 8
        do 480 i2 = 1, 8
        do 480 ml1 = -lind(i1), lind(i1)
        do 480 ml2 = -lind(i2), lind(i2)
           bmat(ml2,0,i2, ml1,0,i1) =   bmat(ml2,0,i2, ml1,0,i1) +
     1                                  bmat(ml2,1,i2, ml1,1,i1)
 480    continue
      elseif (ispin.eq.2 .or. (ispin.eq.1 .and. nspx.eq.1)) then
c       move spin up part into the position of spin-down
        do 490 i1 = 1, 8
        do 490 i2 = 1, 8
        do 490 ml1 = -lind(i1), lind(i1)
        do 490 ml2 = -lind(i2), lind(i2)
           bmat(ml2,0,i2, ml1,0,i1) =   bmat(ml2,1,i2, ml1,1,i1)
 490    continue

      endif

      return
      end