! ------------------------------------------------------ !
! Bubel - benchmark.f90 - Krzysztof Kolasinski 2016
!
! Test of speed and accuracy
! ------------------------------------------------------ !

program transporter

 use modunits   ! unit conversion tools
 use modscatter ! eigen values and transport
 use modlead    ! bandgap structure
 use modshape
 use modutils
 implicit none
 character(*),parameter :: output_folder = "benchmark_output/"
 type(qscatter)             :: qt
 type(qshape)               :: lead_shape
 doubleprecision            :: zeros_vector(200)
 doubleprecision            :: a_dx,a_Emin,a_Emax,a_Bz
 integer                    :: no_expected_states
 integer          :: nx = 50
 integer          :: ny = 50
 doubleprecision,parameter  :: dx = 5.0 ! [nm]

 integer :: i,j,k
 doubleprecision            :: lead_translation_vec(3),Ef,Bz
 doubleprecision :: T_AUTO,T_GGEV,T_SCHUR,T_EXACT ! transmissions
 doubleprecision :: Tm_AUTO,Tm_GGEV,Tm_SCHUR ! timers

! Use atomic units in effective band model -> see modunit.f90 for more details
call modunits_set_GaAs_params()
a_dx = dx * L2LA ! convert it to atomic units
a_Bz = BtoAtomicB(0.45D0) ! 1 Tesla to atomic units

! Enable/Disable part of tests
if(.true.) then
! -------------------------------------------------------------------
! Test 1
! -------------------------------------------------------------------
ny = 50
call create_system(ny,1)

Ef = 5.0/E0/1000.0
call qt%calculate_modes(Ef)
call qt%solve(1,Ef)
! Save calculated electron density to file
do i = 1 , size(qt%qauxvec)
    qt%qauxvec(i) = sum(qt%densities(:,i))
enddo
call qt%qsystem%save_data(output_folder//"densities.xml",array2d=qt%densities,array1d=qt%qauxvec)

call qt%save_system(output_folder//"system_Test1.xml")
open(unit=111,file=output_folder//"Test1.dat")
print*,"Performing energy Test1..."
QSYS_DEBUG_LEVEL = 0 ! show more info
do Ef = 0.0 , 8.0/E0/1000.0 , 8.0/E0/1000.0/80
    ! Update hamiltonian elemenents value
    call qt%qsystem%update_lattice(c_simple=connect)

    QSYS_FORCE_ZGGEV_TO_FIND_MODES = .false.
    QSYS_FORCE_SCHUR_DECOMPOSITION = .false.
    Tm_AUTO = get_clock()
    call qt%calculate_modes(Ef)
    call qt%solve(1,Ef)
    T_AUTO  =sum(qt%Tn(:))+sum(qt%Rn(:))
    T_EXACT = qt%leads(1)%no_in_modes
    Tm_AUTO = get_clock() - Tm_AUTO

    QSYS_FORCE_ZGGEV_TO_FIND_MODES = .true.
    QSYS_FORCE_SCHUR_DECOMPOSITION = .false.
    Tm_GGEV = get_clock()
    call qt%calculate_modes(Ef)
    call qt%solve(1,Ef)
    T_GGEV  = sum(qt%Tn(:))+sum(qt%Rn(:))
    Tm_GGEV = get_clock() - Tm_GGEV

    QSYS_FORCE_ZGGEV_TO_FIND_MODES = .false.
    QSYS_FORCE_SCHUR_DECOMPOSITION = .true.
    Tm_SCHUR = get_clock()
    call qt%calculate_modes(Ef)
    call qt%solve(1,Ef)
    T_SCHUR  =sum(qt%Tn(:))+sum(qt%Rn(:))
    Tm_SCHUR = get_clock() - Tm_SCHUR
    print*,Ef*1000*E0,sum(qt%Tn(:))
    write(111,"(100e20.10)"),Ef*1000*E0,T_EXACT,T_AUTO,T_GGEV,T_SCHUR,Tm_AUTO,Tm_GGEV,Tm_SCHUR
enddo
close(111)

call system("cd "//output_folder//"; python plot_Tests.py 1")

! -------------------------------------------------------------------
! Test 2
! -------------------------------------------------------------------
ny = 80
call create_system(ny,1)

call qt%save_system(output_folder//"system_Test2.xml")
open(unit=111,file=output_folder//"Test2.dat")
print*,"Performing energy Test2..."
QSYS_DEBUG_LEVEL = 0 ! show more info
do Ef = 0.0 , 8.0/E0/1000.0 , 8.0/E0/1000.0/80
    ! Update hamiltonian elemenents value
    call qt%qsystem%update_lattice(c_simple=connect)

    QSYS_FORCE_ZGGEV_TO_FIND_MODES = .false.
    QSYS_FORCE_SCHUR_DECOMPOSITION = .false.
    Tm_AUTO = get_clock()
    call qt%calculate_modes(Ef)
    call qt%solve(1,Ef)
    T_AUTO  =sum(qt%Tn(:))+sum(qt%Rn(:))
    T_EXACT = qt%leads(1)%no_in_modes
    Tm_AUTO = get_clock() - Tm_AUTO

    QSYS_FORCE_ZGGEV_TO_FIND_MODES = .true.
    QSYS_FORCE_SCHUR_DECOMPOSITION = .false.
    Tm_GGEV = get_clock()
    call qt%calculate_modes(Ef)
    call qt%solve(1,Ef)
    T_GGEV  = sum(qt%Tn(:))+sum(qt%Rn(:))
    Tm_GGEV = get_clock() - Tm_GGEV

    QSYS_FORCE_ZGGEV_TO_FIND_MODES = .false.
    QSYS_FORCE_SCHUR_DECOMPOSITION = .true.
    Tm_SCHUR = get_clock()
    call qt%calculate_modes(Ef)
    call qt%solve(1,Ef)
    T_SCHUR  =sum(qt%Tn(:))+sum(qt%Rn(:))
    Tm_SCHUR = get_clock() - Tm_SCHUR
    print*,Ef*1000*E0,sum(qt%Tn(:))
    write(111,"(100e20.10)"),Ef*1000*E0,T_EXACT,T_AUTO,T_GGEV,T_SCHUR,Tm_AUTO,Tm_GGEV,Tm_SCHUR
enddo
close(111)

call system("cd "//output_folder//"; python plot_Tests.py 2")

! -------------------------------------------------------------------
! Test 3
! -------------------------------------------------------------------
ny = 100
call create_system(ny,1)

call qt%save_system(output_folder//"system_Test3.xml")
open(unit=111,file=output_folder//"Test3.dat")
print*,"Performing energy Test3..."
QSYS_DEBUG_LEVEL = 0 ! show more info
do Ef = 0.0 , 8.0/E0/1000.0 , 8.0/E0/1000.0/80
    ! Update hamiltonian elemenents value
    call qt%qsystem%update_lattice(c_simple=connect)

    QSYS_FORCE_ZGGEV_TO_FIND_MODES = .false.
    QSYS_FORCE_SCHUR_DECOMPOSITION = .false.
    Tm_AUTO = get_clock()
    call qt%calculate_modes(Ef)
    call qt%solve(1,Ef)
    T_AUTO  =sum(qt%Tn(:))+sum(qt%Rn(:))
    T_EXACT = qt%leads(1)%no_in_modes
    Tm_AUTO = get_clock() - Tm_AUTO

    QSYS_FORCE_ZGGEV_TO_FIND_MODES = .true.
    QSYS_FORCE_SCHUR_DECOMPOSITION = .false.
    Tm_GGEV = get_clock()
    call qt%calculate_modes(Ef)
    call qt%solve(1,Ef)
    T_GGEV  = sum(qt%Tn(:))+sum(qt%Rn(:))
    Tm_GGEV = get_clock() - Tm_GGEV

    QSYS_FORCE_ZGGEV_TO_FIND_MODES = .false.
    QSYS_FORCE_SCHUR_DECOMPOSITION = .true.
    Tm_SCHUR = get_clock()
    call qt%calculate_modes(Ef)
    call qt%solve(1,Ef)
    T_SCHUR  =sum(qt%Tn(:))+sum(qt%Rn(:))
    Tm_SCHUR = get_clock() - Tm_SCHUR
    print*,Ef*1000*E0,sum(qt%Tn(:))
    write(111,"(100e20.10)"),Ef*1000*E0,T_EXACT,T_AUTO,T_GGEV,T_SCHUR,Tm_AUTO,Tm_GGEV,Tm_SCHUR
enddo
close(111)

call system("cd "//output_folder//"; python plot_Tests.py 3")
endif

if(.true.) then
! -------------------------------------------------------------------
! Test 4
! -------------------------------------------------------------------
ny = 100
nx = 30
call create_system(ny,2)
a_Bz = BtoAtomicB(0.45D0) ! 1 Tesla to atomic units
Ef = 5.0/E0/1000.0
call qt%calculate_modes(Ef)
call qt%solve(1,Ef)
! Save calculated electron density to file
do i = 1 , size(qt%qauxvec)
    qt%qauxvec(i) = sum(qt%densities(:,i))
enddo
call qt%qsystem%save_data(output_folder//"densities.xml",array2d=qt%densities,array1d=qt%qauxvec)

call qt%save_system(output_folder//"system_Test4.xml")
open(unit=111,file=output_folder//"Test4.dat")
print*,"Performing energy Test4..."
QSYS_DEBUG_LEVEL = 0 ! show more info
do Ef = 0.0 , 8.0/E0/1000.0 , 8.0/E0/1000.0/40
    ! Update hamiltonian elemenents value
    call qt%qsystem%update_lattice(c_simple=connect)

    QSYS_FORCE_ZGGEV_TO_FIND_MODES = .false.
    QSYS_FORCE_SCHUR_DECOMPOSITION = .false.
    Tm_AUTO = get_clock()
    call qt%calculate_modes(Ef)
    call qt%solve(1,Ef)
    T_AUTO  =sum(qt%Tn(:))+sum(qt%Rn(:))
    T_EXACT = qt%leads(1)%no_in_modes
    Tm_AUTO = get_clock() - Tm_AUTO

    QSYS_FORCE_ZGGEV_TO_FIND_MODES = .true.
    QSYS_FORCE_SCHUR_DECOMPOSITION = .false.
    Tm_GGEV = get_clock()
    call qt%calculate_modes(Ef)
    call qt%solve(1,Ef)
    T_GGEV  = sum(qt%Tn(:))+sum(qt%Rn(:))
    Tm_GGEV = get_clock() - Tm_GGEV

    QSYS_FORCE_ZGGEV_TO_FIND_MODES = .false.
    QSYS_FORCE_SCHUR_DECOMPOSITION = .true.
    Tm_SCHUR = get_clock()
    call qt%calculate_modes(Ef)
    call qt%solve(1,Ef)
    T_SCHUR  =sum(qt%Tn(:))+sum(qt%Rn(:))
    Tm_SCHUR = get_clock() - Tm_SCHUR
    print*,Ef*1000*E0,sum(qt%Tn(:))
    write(111,"(100e20.10)"),Ef*1000*E0,T_EXACT,T_AUTO,T_GGEV,T_SCHUR,Tm_AUTO,Tm_GGEV,Tm_SCHUR
enddo
close(111)
call system("cd "//output_folder//"; python plot_Tests.py 4")
endif ! end of if ennable/disable second test group

! ----------------------------------------------------------
! X. Clean memory...
! ----------------------------------------------------------
call lead_shape%destroy_shape()
call qt%destroy_system()
print*,"Use Viewer program to see the structure and created leads."
contains

! ---------------------------------------------------------------------------
! This function decides if site A (called here atomA)  has hoping
! to atom B, and what is the value of the coupling.
! If there is no interaction between them returns false, otherwise true.
! ---------------------------------------------------------------------------
logical function connect(atomA,atomB,coupling_val)
    use modcommons
    implicit none
    type(qatom) :: atomA,atomB

    complex*16  :: coupling_val ! you must overwrite this variable
    ! local variables
    integer         :: xdiff,ydiff
    doubleprecision :: dydiff,dxdiff,t0,y

    ! Calculate distance between atoms in units of dx.
    dxdiff = (atomA%atom_pos(1)-atomB%atom_pos(1))/dx
    dydiff = (atomA%atom_pos(2)-atomB%atom_pos(2))/dx

    ! Convert it to integers
    xdiff = NINT(dxdiff)
    ydiff = NINT(dydiff)

    ! default return value
    connect = .false.

    ! hoping parameter
    t0 = 1/(2*m_eff*a_dx**2)

    if( xdiff == 0 .and. ydiff == 0 ) then
        connect      = .true.
        coupling_val = 4*t0
    else if( abs(xdiff) ==  1 .and. ydiff == 0 ) then
        connect = .true.
        ! magnetic Field enters the hamiltonian by phase: EXP(i*DX*Bx*y)
        y = (atomA%atom_pos(2) - ny/2*dx ) * L2LA ! convert to atomic units
        coupling_val = -t0 * EXP(II*xdiff*a_dx*a_Bz*y)
    else if( xdiff ==  0 .and. abs(ydiff) == 1 ) then
        connect = .true.
        coupling_val = -t0
    endif
end function connect

! Create system of with n_y and unit cell lenght l_uc
! The system will contain little hole in the middle
subroutine create_system(n_y,l_uc)
    integer :: n_y , l_uc
    call lead_shape%destroy_shape()
    call qt%destroy_system()
    call qt%init_system()
    ! ----------------------------------------------------------
    ! 1. Create mesh - loop over width and height of the lattice
    ! ----------------------------------------------------------
    do i = 1 , nx
    do j = 1 , n_y
        call qt%qatom%init((/ (i-1) * dx , (j-1) * dx  , 0.0 * dx /))
        if( sqrt(abs(i-nx/2.0)**2) + sqrt(abs(j-n_y/2.0)**2)  < 4. ) then
        else
        call qt%qsystem%add_atom(qt%qatom)
        endif
    enddo
    enddo
    ! ----------------------------------------------------------
    ! 2. Construct logical connections between sites on the mesh.
    ! ----------------------------------------------------------
    qt%qnnbparam%box = (/2*dx,2*dx,0.0D0/) ! do not search for the sites far than (-dx:+dx) direction
    ! Setup connections between sites with provided by you function "connect", see below for example.
    call qt%qsystem%make_lattice(qt%qnnbparam,c_simple=connect)
    ! ----------------------------------------------------------
    ! 3. Use generated mesh to calculate the band structure
    ! in the region of homogenous lead.
    ! ----------------------------------------------------------
    lead_translation_vec = (/  l_uc*dx , 0.0D0 , 0.0D0 /)
    call lead_shape%init_range_3d((/-0.5D0*dx,0.0D0,0.0D0/),lead_translation_vec)
    call qt%add_lead(lead_shape,lead_translation_vec)
end subroutine create_system

end program transporter


*     MB04VD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          MMAX, NMAX
      PARAMETER        ( MMAX = 20, NMAX = 20 )
      INTEGER          LDA, LDE, LDQ, LDZ
      PARAMETER        ( LDA  = MMAX, LDE = MMAX, LDQ = MMAX,
     $                   LDZ = NMAX )
      INTEGER          LINUK
      PARAMETER        ( LINUK = MAX( NMAX,MMAX+1 ) )
*     PARAMETER        ( LINUK = NMAX+MMAX+1 )
      INTEGER          LIWORK
      PARAMETER        ( LIWORK = NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = MAX( NMAX,MMAX ) )
*     PARAMETER        ( LDWORK = NMAX+MMAX )
      DOUBLE PRECISION ZERO, ONE
      PARAMETER        ( ZERO = 0.0D0, ONE = 1.0D0 )
*     .. Local Scalars ..
      DOUBLE PRECISION TOL
      INTEGER          I, INFO, J, M, N, NBLCKI, NBLCKS, RANKE
      CHARACTER*1      JOBQ, JOBZ, MODE
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), DWORK(LDWORK), E(LDE,NMAX),
     $                 Q(LDQ,MMAX), Z(LDZ,NMAX)
      INTEGER          IMUK(LINUK), IMUK0(NMAX), INUK(LINUK),
     $                 ISTAIR(MMAX), IWORK(LIWORK), MNEI(3)
C     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         MB04UD, MB04VD
*     .. 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 = * ) M, N, TOL, MODE
      IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
         WRITE ( NOUT, FMT = 99984 ) M
      ELSE IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99983 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,M )
         READ ( NIN, FMT = * ) ( ( E(I,J), J = 1,N ), I = 1,M )
         JOBQ = 'I'
         JOBZ = 'I'
*        Reduce E to column echelon form and compute Q'*A*Z.
         CALL MB04UD( JOBQ, JOBZ, M, N, A, LDA, E, LDE, Q, LDQ, Z, LDZ,
     $                RANKE, ISTAIR, TOL, DWORK, INFO )
         JOBQ = 'U'
         JOBZ = 'U'
*
         IF ( INFO.EQ.0 ) THEN
*           Compute a unitary transformed pencil Q'*(s*E-A)*Z.
            CALL MB04VD( MODE, JOBQ, JOBZ, M, N, RANKE, A, LDA, E, LDE,
     $                   Q, LDQ, Z, LDZ, ISTAIR, NBLCKS, NBLCKI, IMUK,
     $                   INUK, IMUK0, MNEI, TOL, IWORK, INFO )
*
            IF ( INFO.EQ.0 ) THEN
               WRITE ( NOUT, FMT = 99996 )
               WRITE ( NOUT, FMT = 99995 )
               DO 140 I = 1, M
                  WRITE ( NOUT, FMT = 99994 ) ( Q(I,J), J = 1,M )
  140          CONTINUE
               WRITE ( NOUT, FMT = 99993 )
               DO 160 I = 1, M
                  WRITE ( NOUT, FMT = 99994 ) ( E(I,J), J = 1,N )
  160          CONTINUE
               WRITE ( NOUT, FMT = 99992 )
               DO 180 I = 1, M
                  WRITE ( NOUT, FMT = 99994 ) ( A(I,J), J = 1,N )
  180          CONTINUE
               WRITE ( NOUT, FMT = 99991 )
               DO 200 I = 1, N
                  WRITE ( NOUT, FMT = 99994 ) ( Z(I,J), J = 1,N )
  200          CONTINUE
               WRITE ( NOUT, FMT = 99990 ) NBLCKS
               IF ( .NOT. LSAME( MODE, 'S' ) ) THEN
                  WRITE ( NOUT, FMT = 99989 ) ( IMUK(I),  I = 1,NBLCKS )
                  WRITE ( NOUT, FMT = 99988 ) ( INUK(I),  I = 1,NBLCKS )
               ELSE
                  WRITE ( NOUT, FMT = 99987 ) ( IMUK(I),  I = 1,NBLCKS )
                  WRITE ( NOUT, FMT = 99986 ) ( INUK(I),  I = 1,NBLCKS )
                  WRITE ( NOUT, FMT = 99982 ) ( IMUK0(I), I = 1,NBLCKI )
                  WRITE ( NOUT, FMT = 99985 ) ( MNEI(I),  I = 1,3 )
               END IF
            ELSE
               WRITE ( NOUT, FMT = 99998 ) INFO
            END IF
         ELSE
            WRITE ( NOUT, FMT = 99997 ) INFO
         END IF
      END IF
      STOP
*
99999 FORMAT (' MB04VD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MB04VD = ',I2)
99997 FORMAT (' INFO on exit from MB04UD = ',I2)
99996 FORMAT (' The unitary transformed pencil is Q''*(s*E-A)*Z, where',
     $          /)
99995 FORMAT (' Matrix Q',/)
99994 FORMAT (20(1X,F8.4))
99993 FORMAT (/' Matrix E',/)
99992 FORMAT (/' Matrix A',/)
99991 FORMAT (/' Matrix Z',/)
99990 FORMAT (/' The number of submatrices having full row rank detect',
     $       'ed in matrix A = ',I3)
99989 FORMAT (/' The column dimensions of the submatrices having full ',
     $       'column rank in the pencil',/' sE(eps,inf) - A(eps,inf) a',
     $       're',/20(1X,I5))
99988 FORMAT (/' The row dimensions of the submatrices having full row',
     $       ' rank in the pencil',/' sE(eps,inf) - A(eps,inf) are',
     $       /20(1X,I5))
99987 FORMAT (/' The column dimensions of the submatrices having full ',
     $       'column rank in the pencil',/' sE(eps) - A(eps) are',
     $       /20(1X,I5))
99986 FORMAT (/' The row dimensions of the submatrices having full row',
     $       ' rank in the pencil',/' sE(eps) - A(eps) are',/20(1X,I5))
99985 FORMAT (/' MNEI is ',/20(1X,I5))
99984 FORMAT (/' M is out of range.',/' M = ',I5)
99983 FORMAT (/' N is out of range.',/' N = ',I5)
99982 FORMAT (/' The orders of the diagonal submatrices in the pencil ',
     $       'sE(inf) - A(inf) are',/20(1X,I5))
      END


      SUBROUTINE MJDTODATE (MJD,YR,MN,DY,UT)

c  ------------------------------------------------------------------------
c  Part of "poa_calfos" (STECF/IPMG)
c  Part of "NORAD TLES" based ephemeris program (NASA)
c
c  History:
c  --------
c  Version   Date        Author          Description
c      1.0       Jul 00  M. Rosa         POA calibration code
c  ------------------------------------------------------------------------

c convert Modified Julian Date  to Year, Month, Day and UT(hrs)

      double precision  mjd,ut
      double precision  juld
      integer*4 yr,mn,dy
      integer*4         ja, jb, jc, jd, je

      juld = mjd+2400000.5e0
      ja = nint(juld)
      ut = 24.d0 * (juld - dfloat(ja) + 0.5d0)

      if (ja .ge. 2299161) then
        jb = int (((ja - 1867216) - 0.25) / 36524.25)
        ja = ja + 1 + jb - int (jb / 4)
      endif

      jb = ja + 1524
      jc = int (6680. + ((jb - 2439870) - 122.1) / 365.25d0 )
      jd = 365 * jc + int (jc / 4)
      je = int ((jb - jd) / 30.6001)
      dy = jb - jd - int (30.6001 * je)
      mn = je - 1
      if (mn .gt. 12) mn = mn - 12
      yr = jc - 4715
      if (mn .gt. 2) yr = yr - 1
      if (yr .lt. 0) yr = yr - 1

      return
      end


      program buildwat
      parameter(mx=200)
      real x(mx,mx,mx),y(mx,mx,mx),z(mx,mx,mx)
      real lx,ly,lz,grd,vol,density
      real px,py,pz
      integer i,j,k,ii,jj,kk
      integer nx,ny,nz
      integer natom,nwat

      grd=3.10
      density=1/29.9143
      r0 = 0.9572
      ang = 104.52
      write(6,*)'input Lx,Ly,Lz'
      read(5,*)lx,ly,lz
      vol=lx*ly*lz
      nwat=abs(vol*density)

      nx=abs(lx/grd)
      ny=abs(ly/grd)
      nz=abs(lz/grd)
      px=nx*1.0
      py=ny*1.0
      pz=nz*1.0

c      write(6,*)nx,ny,nz

      write(6,*)'REMARK: water box with dimension',lx,ly,lz

      natom=0
      do i=1,nx+1
         do j=1,ny+1
            do k=1,nz+1
               natom=natom+1
               x(i,j,k)=i*grd-(px+1)/2*grd
               y(i,j,k)=j*grd-(py+1)/2*grd
               z(i,j,k)=k*grd-(pz+1)/2*grd
               if(natom.le.nwat)then
                  write(6,20)(3*natom-2),natom,
     $                 x(i,j,k),y(i,j,k),z(i,j,k)
                  write(6,30)(3*natom-1),natom,
     $                 x(i,j,k)+r0,y(i,j,k),z(i,j,k)
                  write(6,40)(3*natom),natom,x(i,j,k)+r0*cosd(104.52),
     $                 y(i,j,k)+r0*sind(104.52),z(i,j,k)
               endif
            enddo
         enddo
      enddo

      write(6,*)'TER'

 20   format('ATOM ',i6,'  OH2 TIP3',i5,4x,3f8.3)
 30   format('ATOM ',i6,'  H1  TIP3',i5,4x,3f8.3)
 40   format('ATOM ',i6,'  H2  TIP3',i5,4x,3f8.3)

      end


!
!   VnVFPRetJ.f90
!
!
!
!
!
!
!   Created by Kurt Mitman on 14/10/14.
!

DOUBLE PRECISION FUNCTION FnVFPRetJ(bsav)

USE Params
USE Globals
USE funcs
USE Procedures

IMPLICIT NONE

DOUBLE PRECISION, INTENT(IN) :: bsav
DOUBLE PRECISION             :: cons,houseval
DOUBLE PRECISION             :: vals(2)
INTEGER                      :: inds(2)

cons=gliq-FnQb(bsav,gPh*ghouse-gmort)*bsav

if(cons .LT. cmin) then
    FnVFPRetJ = 1.d10+10.0d0*(cmin-cons)

else

    FnVFPRetJ = -1.0d0*(uown(cons,ghouse,gij)+ubequest(bsav+gPh*ghouse-gmort*(1.0d0+grm)-FnAdj(gPh*ghouse)))

endif

END FUNCTION FnVFPRetJ


      recursive
     *subroutine lmder(fcn,m,n,x,fvec,fjac,ldfjac,ftol,xtol,gtol,
     *                 maxfev,diag,mode,factor,nprint,info,nfev,njev,
     *                 ipvt,qtf,wa1,wa2,wa3,wa4)
      integer m,n,ldfjac,maxfev,mode,nprint,info,nfev,njev
      integer ipvt(n)
      double precision ftol,xtol,gtol,factor
      double precision x(n),fvec(m),fjac(ldfjac,n),diag(n),qtf(n),
     *                 wa1(n),wa2(n),wa3(n),wa4(m)
c     **********
c
c     subroutine lmder
c
c     the purpose of lmder is to minimize the sum of the squares of
c     m nonlinear functions in n variables by a modification of
c     the levenberg-marquardt algorithm. the user must provide a
c     subroutine which calculates the functions and the jacobian.
c
c     the subroutine statement is
c
c       subroutine lmder(fcn,m,n,x,fvec,fjac,ldfjac,ftol,xtol,gtol,
c                        maxfev,diag,mode,factor,nprint,info,nfev,
c                        njev,ipvt,qtf,wa1,wa2,wa3,wa4)
c
c     where
c
c       fcn is the name of the user-supplied subroutine which
c         calculates the functions and the jacobian. fcn must
c         be declared in an external statement in the user
c         calling program, and should be written as follows.
c
c         subroutine fcn(m,n,x,fvec,fjac,ldfjac,iflag)
c         integer m,n,ldfjac,iflag
c         double precision x(n),fvec(m),fjac(ldfjac,n)
c         ----------
c         if iflag = 1 calculate the functions at x and
c         return this vector in fvec. do not alter fjac.
c         if iflag = 2 calculate the jacobian at x and
c         return this matrix in fjac. do not alter fvec.
c         ----------
c         return
c         end
c
c         the value of iflag should not be changed by fcn unless
c         the user wants to terminate execution of lmder.
c         in this case set iflag to a negative integer.
c
c       m is a positive integer input variable set to the number
c         of functions.
c
c       n is a positive integer input variable set to the number
c         of variables. n must not exceed m.
c
c       x is an array of length n. on input x must contain
c         an initial estimate of the solution vector. on output x
c         contains the final estimate of the solution vector.
c
c       fvec is an output array of length m which contains
c         the functions evaluated at the output x.
c
c       fjac is an output m by n array. the upper n by n submatrix
c         of fjac contains an upper triangular matrix r with
c         diagonal elements of nonincreasing magnitude such that
c
c                t     t           t
c               p *(jac *jac)*p = r *r,
c
c         where p is a permutation matrix and jac is the final
c         calculated jacobian. column j of p is column ipvt(j)
c         (see below) of the identity matrix. the lower trapezoidal
c         part of fjac contains information generated during
c         the computation of r.
c
c       ldfjac is a positive integer input variable not less than m
c         which specifies the leading dimension of the array fjac.
c
c       ftol is a nonnegative input variable. termination
c         occurs when both the actual and predicted relative
c         reductions in the sum of squares are at most ftol.
c         therefore, ftol measures the relative error desired
c         in the sum of squares.
c
c       xtol is a nonnegative input variable. termination
c         occurs when the relative error between two consecutive
c         iterates is at most xtol. therefore, xtol measures the
c         relative error desired in the approximate solution.
c
c       gtol is a nonnegative input variable. termination
c         occurs when the cosine of the angle between fvec and
c         any column of the jacobian is at most gtol in absolute
c         value. therefore, gtol measures the orthogonality
c         desired between the function vector and the columns
c         of the jacobian.
c
c       maxfev is a positive integer input variable. termination
c         occurs when the number of calls to fcn with iflag = 1
c         has reached maxfev.
c
c       diag is an array of length n. if mode = 1 (see
c         below), diag is internally set. if mode = 2, diag
c         must contain positive entries that serve as
c         multiplicative scale factors for the variables.
c
c       mode is an integer input variable. if mode = 1, the
c         variables will be scaled internally. if mode = 2,
c         the scaling is specified by the input diag. other
c         values of mode are equivalent to mode = 1.
c
c       factor is a positive input variable used in determining the
c         initial step bound. this bound is set to the product of
c         factor and the euclidean norm of diag*x if nonzero, or else
c         to factor itself. in most cases factor should lie in the
c         interval (.1,100.).100. is a generally recommended value.
c
c       nprint is an integer input variable that enables controlled
c         printing of iterates if it is positive. in this case,
c         fcn is called with iflag = 0 at the beginning of the first
c         iteration and every nprint iterations thereafter and
c         immediately prior to return, with x, fvec, and fjac
c         available for printing. fvec and fjac should not be
c         altered. if nprint is not positive, no special calls
c         of fcn with iflag = 0 are made.
c
c       info is an integer output variable. if the user has
c         terminated execution, info is set to the (negative)
c         value of iflag. see description of fcn. otherwise,
c         info is set as follows.
c
c         info = 0  improper input parameters.
c
c         info = 1  both actual and predicted relative reductions
c                   in the sum of squares are at most ftol.
c
c         info = 2  relative error between two consecutive iterates
c                   is at most xtol.
c
c         info = 3  conditions for info = 1 and info = 2 both hold.
c
c         info = 4  the cosine of the angle between fvec and any
c                   column of the jacobian is at most gtol in
c                   absolute value.
c
c         info = 5  number of calls to fcn with iflag = 1 has
c                   reached maxfev.
c
c         info = 6  ftol is too small. no further reduction in
c                   the sum of squares is possible.
c
c         info = 7  xtol is too small. no further improvement in
c                   the approximate solution x is possible.
c
c         info = 8  gtol is too small. fvec is orthogonal to the
c                   columns of the jacobian to machine precision.
c
c       nfev is an integer output variable set to the number of
c         calls to fcn with iflag = 1.
c
c       njev is an integer output variable set to the number of
c         calls to fcn with iflag = 2.
c
c       ipvt is an integer output array of length n. ipvt
c         defines a permutation matrix p such that jac*p = q*r,
c         where jac is the final calculated jacobian, q is
c         orthogonal (not stored), and r is upper triangular
c         with diagonal elements of nonincreasing magnitude.
c         column j of p is column ipvt(j) of the identity matrix.
c
c       qtf is an output array of length n which contains
c         the first n elements of the vector (q transpose)*fvec.
c
c       wa1, wa2, and wa3 are work arrays of length n.
c
c       wa4 is a work array of length m.
c
c     subprograms called
c
c       user-supplied ...... fcn
c
c       minpack-supplied ... dpmpar,enorm,lmpar,qrfac
c
c       fortran-supplied ... dabs,dmax1,dmin1,dsqrt,mod
c
c     argonne national laboratory. minpack project. march 1980.
c     burton s. garbow, kenneth e. hillstrom, jorge j. more
c
c     **********
      integer i,iflag,iter,j,l
      double precision actred,delta,dirder,epsmch,fnorm,fnorm1,gnorm,
     *                 one,par,pnorm,prered,p1,p5,p25,p75,p0001,ratio,
     *                 sum,temp,temp1,temp2,xnorm,zero
      double precision dpmpar,enorm
      data one,p1,p5,p25,p75,p0001,zero
     *     /1.0d0,1.0d-1,5.0d-1,2.5d-1,7.5d-1,1.0d-4,0.0d0/
c
c     epsmch is the machine precision.
c
      epsmch = dpmpar(1)
c
      info = 0
      iflag = 0
      nfev = 0
      njev = 0
c
c     check the input parameters for errors.
c
      if (n .le. 0 .or. m .lt. n .or. ldfjac .lt. m
     *    .or. ftol .lt. zero .or. xtol .lt. zero .or. gtol .lt. zero
     *    .or. maxfev .le. 0 .or. factor .le. zero) go to 300
      if (mode .ne. 2) go to 20
      do 10 j = 1, n
         if (diag(j) .le. zero) go to 300
   10    continue
   20 continue
c
c     evaluate the function at the starting point
c     and calculate its norm.
c
      iflag = 1
      call fcn(m,n,x,fvec,fjac,ldfjac,iflag)
      nfev = 1
      if (iflag .lt. 0) go to 300
      fnorm = enorm(m,fvec)
c
c     initialize levenberg-marquardt parameter and iteration counter.
c
      par = zero
      iter = 1
c
c     beginning of the outer loop.
c
   30 continue
c
c        calculate the jacobian matrix.
c
         iflag = 2
         call fcn(m,n,x,fvec,fjac,ldfjac,iflag)
         njev = njev + 1
         if (iflag .lt. 0) go to 300
c
c        if requested, call fcn to enable printing of iterates.
c
         if (nprint .le. 0) go to 40
         iflag = 0
         if (mod(iter-1,nprint) .eq. 0)
     *      call fcn(m,n,x,fvec,fjac,ldfjac,iflag)
         if (iflag .lt. 0) go to 300
   40    continue
c
c        compute the qr factorization of the jacobian.
c
         call qrfac(m,n,fjac,ldfjac,.true.,ipvt,n,wa1,wa2,wa3)
c
c        on the first iteration and if mode is 1, scale according
c        to the norms of the columns of the initial jacobian.
c
         if (iter .ne. 1) go to 80
         if (mode .eq. 2) go to 60
         do 50 j = 1, n
            diag(j) = wa2(j)
            if (wa2(j) .eq. zero) diag(j) = one
   50       continue
   60    continue
c
c        on the first iteration, calculate the norm of the scaled x
c        and initialize the step bound delta.
c
         do 70 j = 1, n
            wa3(j) = diag(j)*x(j)
   70       continue
         xnorm = enorm(n,wa3)
         delta = factor*xnorm
         if (delta .eq. zero) delta = factor
   80    continue
c
c        form (q transpose)*fvec and store the first n components in
c        qtf.
c
         do 90 i = 1, m
            wa4(i) = fvec(i)
   90       continue
         do 130 j = 1, n
            if (fjac(j,j) .eq. zero) go to 120
            sum = zero
            do 100 i = j, m
               sum = sum + fjac(i,j)*wa4(i)
  100          continue
            temp = -sum/fjac(j,j)
            do 110 i = j, m
               wa4(i) = wa4(i) + fjac(i,j)*temp
  110          continue
  120       continue
            fjac(j,j) = wa1(j)
            qtf(j) = wa4(j)
  130       continue
c
c        compute the norm of the scaled gradient.
c
         gnorm = zero
         if (fnorm .eq. zero) go to 170
         do 160 j = 1, n
            l = ipvt(j)
            if (wa2(l) .eq. zero) go to 150
            sum = zero
            do 140 i = 1, j
               sum = sum + fjac(i,j)*(qtf(i)/fnorm)
  140          continue
            gnorm = dmax1(gnorm,dabs(sum/wa2(l)))
  150       continue
  160       continue
  170    continue
c
c        test for convergence of the gradient norm.
c
         if (gnorm .le. gtol) info = 4
         if (info .ne. 0) go to 300
c
c        rescale if necessary.
c
         if (mode .eq. 2) go to 190
         do 180 j = 1, n
            diag(j) = dmax1(diag(j),wa2(j))
  180       continue
  190    continue
c
c        beginning of the inner loop.
c
  200    continue
c
c           determine the levenberg-marquardt parameter.
c
            call lmpar(n,fjac,ldfjac,ipvt,diag,qtf,delta,par,wa1,wa2,
     *                 wa3,wa4)
c
c           store the direction p and x + p. calculate the norm of p.
c
            do 210 j = 1, n
               wa1(j) = -wa1(j)
               wa2(j) = x(j) + wa1(j)
               wa3(j) = diag(j)*wa1(j)
  210          continue
            pnorm = enorm(n,wa3)
c
c           on the first iteration, adjust the initial step bound.
c
            if (iter .eq. 1) delta = dmin1(delta,pnorm)
c
c           evaluate the function at x + p and calculate its norm.
c
            iflag = 1
            call fcn(m,n,wa2,wa4,fjac,ldfjac,iflag)
            nfev = nfev + 1
            if (iflag .lt. 0) go to 300
            fnorm1 = enorm(m,wa4)
c
c           compute the scaled actual reduction.
c
            actred = -one
            if (p1*fnorm1 .lt. fnorm) actred = one - (fnorm1/fnorm)**2
c
c           compute the scaled predicted reduction and
c           the scaled directional derivative.
c
            do 230 j = 1, n
               wa3(j) = zero
               l = ipvt(j)
               temp = wa1(l)
               do 220 i = 1, j
                  wa3(i) = wa3(i) + fjac(i,j)*temp
  220             continue
  230          continue
            temp1 = enorm(n,wa3)/fnorm
            temp2 = (dsqrt(par)*pnorm)/fnorm
            prered = temp1**2 + temp2**2/p5
            dirder = -(temp1**2 + temp2**2)
c
c           compute the ratio of the actual to the predicted
c           reduction.
c
            ratio = zero
            if (prered .ne. zero) ratio = actred/prered
c
c           update the step bound.
c
            if (ratio .gt. p25) go to 240
               if (actred .ge. zero) temp = p5
               if (actred .lt. zero)
     *            temp = p5*dirder/(dirder + p5*actred)
               if (p1*fnorm1 .ge. fnorm .or. temp .lt. p1) temp = p1
               delta = temp*dmin1(delta,pnorm/p1)
               par = par/temp
               go to 260
  240       continue
               if (par .ne. zero .and. ratio .lt. p75) go to 250
               delta = pnorm/p5
               par = p5*par
  250          continue
  260       continue
c
c           test for successful iteration.
c
            if (ratio .lt. p0001) go to 290
c
c           successful iteration. update x, fvec, and their norms.
c
            do 270 j = 1, n
               x(j) = wa2(j)
               wa2(j) = diag(j)*x(j)
  270          continue
            do 280 i = 1, m
               fvec(i) = wa4(i)
  280          continue
            xnorm = enorm(n,wa2)
            fnorm = fnorm1
            iter = iter + 1
  290       continue
c
c           tests for convergence.
c
            if (dabs(actred) .le. ftol .and. prered .le. ftol
     *          .and. p5*ratio .le. one) info = 1
            if (delta .le. xtol*xnorm) info = 2
            if (dabs(actred) .le. ftol .and. prered .le. ftol
     *          .and. p5*ratio .le. one .and. info .eq. 2) info = 3
            if (info .ne. 0) go to 300
c
c           tests for termination and stringent tolerances.
c
            if (nfev .ge. maxfev) info = 5
            if (dabs(actred) .le. epsmch .and. prered .le. epsmch
     *          .and. p5*ratio .le. one) info = 6
            if (delta .le. epsmch*xnorm) info = 7
            if (gnorm .le. epsmch) info = 8
            if (info .ne. 0) go to 300
c
c           end of the inner loop. repeat if iteration unsuccessful.
c
            if (ratio .lt. p0001) go to 200
c
c        end of the outer loop.
c
         go to 30
  300 continue
c
c     termination, either normal or user imposed.
c
      if (iflag .lt. 0) info = iflag
      iflag = 0
      if (nprint .gt. 0) call fcn(m,n,x,fvec,fjac,ldfjac,iflag)
      return
c
c     last card of subroutine lmder.
c
      end


!    ...................................
!    From interaction to HFB fileds
!    eMax08: 11-13 seconds
!    ...................................
        subroutine HFB_Energy_COMPLEX(zro,zkapa10,zkapa01,zakin,zEkin,zEHFB,NLEV,lpr)
!      ..............................................................
        USE VAPHFB_PAR
        implicit real*8 (a-h,o-y)
        implicit complex*16 (z)
        logical lpr
        integer :: myID,OMP_GET_NUM_THREADS, OMP_GET_THREAD_NUM
        real*8    Delta_max
        DIMENSION zro(NLEV,NLEV)
        DIMENSION zkapa10(NLEV,NLEV)
        DIMENSION zkapa01(NLEV,NLEV)
        DIMENSION zakin(NLEV,NLEV)
        DIMENSION zgamma(NLEV,NLEV)
        DIMENSION zham(NLEV,NLEV)
        DIMENSION zdelta10(NLEV,NLEV)
        DIMENSION zdelta01(NLEV,NLEV)

        real*8 omp_get_wtime,t0,t1
      if(lpr) then
        t0 = omp_get_wtime()
        write(*,'(a30)',advance='no') '  Computing the
/<R> ...'
      endif
      zEHFB = zzero
! Using the OpenMP takes even longer time
!!$OMP PARALLEL DEFAULT(PRIVATE) SHARED(zEHFB,H,ZRO,ZKAPA10,ZKAPA01)
!!$OMP DO SCHEDULE(DYNAMIC) REDUCTION(+:zEHFB)
      do iabcd=1,H%iabcd_max !iabcd_max
          k_i = H%ka(iabcd)
          k_j = H%kb(iabcd)
          k_k = H%kc(iabcd)
          k_l = H%kd(iabcd)

          V2B = H%ME2BM(iabcd)

       zrho_ijkl = (ZRO(k_k,k_i)*ZRO(k_l,k_j)                &
     &              -ZRO(k_l,k_i)*ZRO(k_k,k_j)                &
     &              +ZKAPA01(k_i,k_j)*ZKAPA10(k_k,k_l))

       zrho_jikl = (ZRO(k_k,k_j)*ZRO(k_l,k_i)                &
     &              -ZRO(k_l,k_j)*ZRO(k_k,k_i)                &
     &              +ZKAPA01(k_j,k_i)*ZKAPA10(k_k,k_l))

       zrho_jilk = (ZRO(k_l,k_j)*ZRO(k_k,k_i)                &
     &              -ZRO(k_k,k_j)*ZRO(k_l,k_i)                &
     &              +ZKAPA01(k_j,k_i)*ZKAPA10(k_l,k_k))

        zrho_ijlk = (ZRO(k_l,k_i)*ZRO(k_k,k_j)                &
     &              -ZRO(k_k,k_i)*ZRO(k_l,k_j)                &
     &              +ZKAPA01(k_i,k_j)*ZKAPA10(k_l,k_k))

!   -------- ij <--> kl
        zrho_klij = (ZRO(k_i,k_k)*ZRO(k_j,k_l)                &
     &              -ZRO(k_j,k_k)*ZRO(k_i,k_l)                &
     &              +ZKAPA01(k_k,k_l)*ZKAPA10(k_i,k_j))

        zrho_klji = (ZRO(k_j,k_k)*ZRO(k_i,k_l)                &
     &              -ZRO(k_i,k_k)*ZRO(k_j,k_l)                &
     &              +ZKAPA01(k_k,k_l)*ZKAPA10(k_j,k_i))

        zrho_lkij = (ZRO(k_i,k_l)*ZRO(k_j,k_k)                &
     &              -ZRO(k_j,k_l)*ZRO(k_i,k_k)                &
     &              +ZKAPA01(k_l,k_k)*ZKAPA10(k_i,k_j))

        zrho_lkji = (ZRO(k_j,k_l)*ZRO(k_i,k_k)                &
     &              -ZRO(k_i,k_l)*ZRO(k_j,k_k)                &
     &              +ZKAPA01(k_l,k_k)*ZKAPA10(k_j,k_i))

       d_ij_kl = 1.d0

       if((k_k+k_l).eq.(k_i+k_j)) d_ij_kl= 0.d0

        zEHFB = zEHFB + 0.25*V2B*(zrho_ijkl+d_ij_kl*zrho_klij-zrho_jikl-d_ij_kl*zrho_klji   &
     &                           -zrho_ijlk-d_ij_kl*zrho_lkij+zrho_jilk+d_ij_kl*zrho_lkji)

       enddo ! iabcd
!!$OMP  END DO
!!$OMP  END PARALLEL

        zEkin = zzero
        do ia=1,NLEV
         do ic=1,NLEV
            zEkin = zEkin +  ZRO(ic,ia) * zakin(ia,ic) ! H%ME1BM(ia,ic) * ZRO(ia,ic)  !zakin(ia,ic)
         end do
        end do
            zEHFB = zEHFB + zEkin

        if(lpr) then
          write(*,'(a5)',advance='no') 'done'
          t1 = omp_get_wtime()
          write(*,'(a20,f10.5)',advance='no'), '...Time elapsed:',t1-t0
          write(*,'(a14,2f15.8)') '
/<R>=',zEHFB
        endif
        return

        end subroutine


	SUBROUTINE WINDOFFS(IPRINT)
C
C	CALCULATES OFFSETS FROM A SINE WAVE TEST
C
	CHARACTER*128 STR(7)
	COMMON /SPBLK/ PWRW(512),PWRNW(512),FDATA(1024),DATA(1024),IFMAX
	COMMON /PLOTDT/ ITERM,FFTAVR,NDRV,AMP,IWINDW,STR
c
	common /fftblk/ nexpt(1024),ndata(1024)
	common /headblk/ major,minor,ifftch,scet
	character*32 scet
c
C	10 CHANNELS, 4 GAINS, 9 EXAMPLES OF EACH
	DIMENSION OFFSTR(10,4,13),NCOUNT(10,4)            ! HOLDS UP TO 9 VALUES
	DIMENSION X(25),DX(25),Y(25)
	DATA NCOUNT /40*0/
	DATA TWOPI /6.2831853/
C
C	DETERMINE FREQUENCY BY DOING A FOURIER TRANSFORM
C
	CALL TIMEFFT
C
C	NOW DO HUNTMN TO FIND EXACT FREQUENCY AND AMPLITUDES
C
	X(1) = FLOAT(IFMAX)/FLOAT(NPROS)
	DX(2) = .5/FLOAT(NPROS)
	SUMSQS = 1..E6
	DO IT = 1,10
	  CALL HUNTMN(1,X,DX,Y,SINFIT,SUMSQ)
	  PRINT*,'HUNTMN',IT,X(1),SUMSQ
	  SUMSQS = SUMSQ
	ENDDO
C
	IF(IPRINT.NE.0) THEN
	  DO ICH = 1,6
	    DO NE = 1,4
	      NP = NCOUNT(ICH,NE)
	      PRINT 1005,ICH,NE-1,(OFFSTR(ICH,NE,N),N=1,NP)
	      WRITE(26,1005) ICH,NE-1,(OFFSTR(ICH,NE,N),N=1,NP)
 1005	      FORMAT(I4,I3,13F8.1)
	    ENDDO
	  ENDDO
	  NE = 4
	  DO ICH = 7,9
	    NP = NCOUNT(ICH,NE)
	    PRINT 1005,ICH,NE-1,(OFFSTR(ICH,NE,N),N=1,NP)
	    WRITE(26,1005) ICH,NE-1,(OFFSTR(ICH,NE,N),N=1,NP)
	  ENDDO
	  NE = 3
	  ICH = 10
	  NP = NCOUNT(ICH,NE)
	  PRINT 1005,ICH,NE-1,(OFFSTR(ICH,NE,N),N=1,NP)
	  WRITE(26,1005) ICH,NE-1,(OFFSTR(ICH,NE,N),N=1,NP)
	ENDIF
C
 1001	FORMAT(I4,1X,20I5)
 1002	FORMAT(A)
 1003	FORMAT(' scet',a32,'  s/c maj,min frame',I6,'.',I3.3)
 1004	FORMAT(A15,4F12.3)
	PRINT 1003,MAJOR,MINOR
	PRINT *,' FFT CHANNEL',IFFTCH
	PRINT *,' scet ',SCET
	print*,'1st,last data',ndata(1),ndata(1024)
	print*,'1st,last expt',nexpt(1),nexpt(1024)
C
C	WRITE(16, 1003) MAJOR,MINOR
C	WRITE(16,*)' FFT CHANNEL',IFFTCH
C	WRITE(16,*) ' scet ',SCET
C	WRITE(16,*) '1st,last data',ndata(1),ndata(1024)
C	WRITE(16,*)'1st,last expt',nexpt(1),nexpt(1024)
C
C
	DAMAX = -1.E7
	DAMIN =  1.E7
	DO IK = 1,1024
	  NTEMP = NDATA(IK).AND.4095
	  TEMP = -(NTEMP-2048)
	  DATA(IK) = TEMP*(-16.)**NEXPT(IK)
	  FDATA(IK) = ABS(TEMP)+2048.*NEXPT(IK)
	  IF(DATA(IK).LT.0.) FDATA(IK) = -FDATA(IK)
	  IF(FDATA(IK).GT.DAMAX) THEN
	    MAXEXP = NEXPT(IK)
	    MAXDAT = NDATA(IK)
	    DAMAX = FDATA(IK)
	  ENDIF
	  IF(FDATA(IK).LT.DAMIN) THEN
	    MINEXP = NEXPT(IK)
	    MINDAT = NDATA(IK)
	    DAMIN = FDATA(IK)
	  ENDIF
	ENDDO
C
	IF(MAXEXP.EQ.MINEXP) THEN
	  NP = NCOUNT(IFFTCH,MINEXP+1) + 1
	  OFFSTR(IFFTCH,MINEXP+1,NP) = .5*(MAXDAT+MINDAT)
	  NCOUNT(IFFTCH,MINEXP+1)  = NP
	ENDIF
C
C	WRITE(16,*) 'min,max data,expt',mindat,minexp,maxdat,maxexp
C
C
	RETURN
	END


SUBROUTINE SEDZLJ_SHEAR

  USE GLOBAL
  IMPLICIT NONE

  INTEGER::L
  INTEGER::M1,M2
  INTEGER::FZONE
  !PT: All real values are explicitly written in DOUBLE PRECISION 7/16/08.
  DOUBLE PRECISION::MMW,SIGMAWV,JJW
  DOUBLE PRECISION::VELMAG,VELANG,DELW,APROUGH
  DOUBLE PRECISION::UTMP,VTMP
  DOUBLE PRECISION::WVLENGTH,WVANGLE,WFTIM,EXCURSION
  DOUBLE PRECISION::FC1,FC2,FWINDSQ
  DOUBLE PRECISION::FWINDS,FWINDD
  DOUBLE PRECISION::TDIFF,WTM1,WTM2,AVGDEPTH
  DOUBLE PRECISION,DIMENSION(LCM)::ZBTEMP
  REAL:: FC3
  ! CALCULATES Wave and Current Shear Stress Based on Log-Law of Cristofferson Jonsson
  !
  ! REVISION DATE :  May 24, 2007
  ! Craig Jones and Scott James
  !**************************************************************************
  ! Check to see if we've set a constant Tau

  IF(TAUCONST==0)THEN
     !
     !******************************************************
     IF(ISWNWAVE==1)THEN
        !
        !**************************************************************************
        ! Wind Wave Fetch
        !
        ! Convert wind input into current wind info for wind-driven wave calcs
        IF(ISDYNSTP==0)THEN
           WFTIM=DT*FLOAT(N)/TCWSER(1)+TBEGIN*(TCON/TCWSER(1))
        ELSE
           WFTIM=TIMESEC/TCWSER(1)
        ENDIF
        M1=MWTLAST(1)
        M2=M1+1
        DO WHILE(TWSER(M2,1)<WFTIM)
           M1=M2
           M2=M1+1
        ENDDO
        MWTLAST(1)=M1
        TDIFF=TWSER(M2,1)-TWSER(M1,1)
        WTM1=(TWSER(M2,1)-WFTIM)/TDIFF
        WTM2=(WFTIM-TWSER(M1,1))/TDIFF
        FWINDS=WTM1*WINDS(M1,1)+WTM2*WINDS(M2,1)
        IF(FWINDS>1.0)THEN
           IF(ABS(WINDD(M1,1)-WINDD(M2,1))<180.0)THEN
              FWINDD=WTM1*WINDD(M1,1)+WTM2*WINDD(M2,1)
           ELSE
              IF(WINDD(M1,1).GT.WINDD(M2,1))THEN
                 FWINDD=WTM1*WINDD(M1,1)+WTM2*(WINDD(M2,1)+360.0)
              ELSE
                 FWINDD=WTM1*(WINDD(M1,1)+360)+WTM2*WINDD(M2,1)
              ENDIF
              IF(FWINDD>=360.0)FWINDD=FWINDD-360.0
           ENDIF
           ! Convert wind into direction it is blowing "from"
           IF(FWINDD<=180.0)THEN
              FWINDD=FWINDD+180.0
              IF(FWINDD==360.0)FWINDD=0.0
           ELSE
              FWINDD=FWINDD-180.0
              IF(FWINDD==360.0)FWINDD=0.0
           ENDIF
           ! Calculate which of the 8 wind zones (FWZONE) the wind is coming from
           ! Also the Waveangle CCW from East
           IF(FWINDD>=337.5.OR.FWINDD<22.5)THEN
              FZONE=1
              WVANGLE=4.712
           ELSEIF(FWINDD>=22.5.AND.FWINDD<67.5)THEN
              FZONE=2
              WVANGLE=3.927
           ELSEIF(FWINDD>=67.5.AND.FWINDD<112.5)THEN
              FZONE=3
              WVANGLE=3.142
           ELSEIF(FWINDD>=112.5.AND.FWINDD<157.5)THEN
              FZONE=4
              WVANGLE=2.356
           ELSEIF(FWINDD>=157.5.AND.FWINDD<202.5)THEN
              FZONE=5
              WVANGLE=1.571
           ELSEIF(FWINDD>=202.5.AND.FWINDD<247.5)THEN
              FZONE=6
              WVANGLE=0.7854
           ELSEIF(FWINDD>=247.5.AND.FWINDD<292.5)THEN
              FZONE=7
              WVANGLE=0.
           ELSEIF(FWINDD>=292.5.AND.FWINDD<337.5)THEN
              FZONE=8
              WVANGLE=5.4978
           ENDIF
           !Calculate Domain Average Depth
           !Needs to be calculated along each fetch
           !This is sufficient for small systems
           AVGDEPTH=SUM(HP(2:LA))/FLOAT(LA-1)
           FWINDSQ=FWINDS*FWINDS
        ENDIF

           !Calculate wave height, period, orbital velocity, and length
           DO L=2,LA
              FC1=(FWINDSQ/9.8)*0.283*TANH(0.530*(9.8*AVGDEPTH/FWINDSQ)**0.75)
              FC2=TANH(0.0125*(9.8*FWDIR(L,FZONE)/FWINDSQ)**0.42/TANH(0.530*(9.8*AVGDEPTH/FWINDSQ)**0.75))
              FC3=FC1*FC2
              FWVHT(L)=MIN(HP(L),FC3) !taking min of real/doubleprecision causes issues in AIX;
              !FWVHT(L)=MIN(0.6*HP(L),FWVHT(L))

              FC1=(FWINDS/9.8)*7.54*TANH(0.833*(9.8*AVGDEPTH/FWINDSQ)**0.375)
              FC2=TANH(0.077*(9.8*FWDIR(L,FZONE)/FWINDSQ)**0.25/TANH(0.833*(9.8*AVGDEPTH/FWINDSQ)**0.375))
              FWVTP(L)=FC1*FC2
              WVFREQ(L)=2.0*PI/FWVTP(L)

              !FC1=(2.0*PI/FWVTP(L))**2*HP(L)/9.8
              !FC2=FC1+1.0/(1.0+0.6522*(FC1)+0.4622*(FC1)**2+0.0864*(FC1)**4+0.0675*(FC1)**5)
              WVLENGTH=FWVTP(L)*SQRT(9.8*HP(L)/FC2)
              WVLENGTH=MAX(1.d0,WVLENGTH)
              !WVORBIT(L)=PI*FWVHT(L)/(FWVTP(L)*SINH(HP(L)*2.0*PI/WVLENGTH))
              WVORBIT(L)=MAX(0.01d0,PI*FWVHT(L)/(FWVTP(L)*SINH(HP(L)*2.0*PI/WVLENGTH)))
           ENDDO
           !*************************************************************************
           !Read in EFDC STWAVE Wave Field

      ELSEIF(ISWNWAVE==2)THEN

           NWVCOUNT=NWVCOUNT+DT/3600
           IF(NWVCOUNT==STWVTIM)THEN
              NWVCOUNT=0
              STINC=STINC+1
              DO L=2,LA
                 IF(STINC>STWVNUM)EXIT
                 IF(STWVTP(L,STINC)>0.0.AND.ISCDRY(L).EQ.0)THEN
                    WVFREQ(L)=2.0*PI/STWVTP(L,STINC)
                    FC3 = STWVHT(L,STINC)
                    FWVHT(L)=MIN(HP(L),FC3)
!                    FC1=(2.0*PI/STWVTP(L,STINC))**2*HP(L)/9.8
!                    FC2=FC1+1.0/(1.0+0.6522*(FC1)+0.4622*(FC1)**2+0.0864*(FC1)**4+0.0675*(FC1)**5)
!                    WVLENGTH=STWVTP(L,STINC)*SQRT(9.8*HP(L)/FC2)
                    FC1=9.8*STWVTP(L,STINC)**2
                    FC2=2.*PI*SQRT(TANH(4.*PI**2*HP(L)/(STWVTP(L,STINC)**2*9.8)))
                    WVLENGTH=FC1/FC2
                    EXCURSION=FWVHT(L)/(2.*SINH((2.*PI/WVLENGTH)*HP(L)))
                    WVORBIT(L)=EXCURSION*WVFREQ(L)
                    WVORBIT(L)=MAX(0.01d0,WVORBIT(L))
                    WVANG(L)=STWVDR(L,STINC)
                 ELSE
                    WVFREQ(L)=0.0
                    WVORBIT(L)=0.0
                    WVANG(L)=0.0
                 ENDIF
              ENDDO
           ENDIF
       ENDIF
     !*************************************************************************
     !Begin shear stress calculations
     !Set up roughness, velocities, and angles

     DO L=2,LA
        ZBTEMP(L)=ZBR(L)
        IF(ZBSKIN.EQ.0.AND.NSEDFLUME.GT.0)THEN
           IF(D50AVG(L).LT.D50(1))THEN
              ZBTEMP(L)=D50(1)/1e6
           ELSE
              ZBTEMP(L)=D50AVG(L)/1e6
           ENDIF
        ELSEIF(ZBSKIN.GT.0.AND.NSEDFLUME.GT.0)THEN
           ZBTEMP(L)=ZBSKIN/1e6
        ENDIF
     ENDDO

     DO L=2,LA
        IF(LMASKDRY(L).AND.HP(L).GT.0.5)THEN
          IF(ISWAVE.EQ.2) ZBTEMP(L)=0.0001
          KN(L)=30.0*ZBTEMP(L)
          ! Calculate Average Velocity Magnitude in cm/s
          UTMP=100.0*STCUV(L)*(UHE(LEAST(L))+UHE(L))/(HU(LEAST(L))+HU(L))+1.0E-12
          VTMP=100.0*STCUV(L)*(VHE(LNC(L))+VHE(L))/(HV(LNC(L))+HV(L))
          VELMAG=SQRT(UTMP**2+VTMP**2)
          ! Calculate Initial Friction Factors
          FC(L)=(0.42/LOG(HP(L)/(2.0*ZBTEMP(L))))**2
          ! Current only Shear Stress
          IF(ISWNWAVE==0.AND.UWVSQ(L)==0.0.OR.ISWAVE==0)THEN
             TAU(L)=FC(L)*VELMAG**2
          ELSE
             !Calculate Combined Wave Friction Factor
             ! Calculate Current Angle CCW From X axis
             IF(UTMP>0.0.AND.VTMP>0.0)THEN
                VELANG=ATAN(VTMP/UTMP)
             ELSEIF(UTMP<0.0)THEN
                VELANG=ATAN(VTMP/UTMP)+PI
             ELSEIF(UTMP>0.0.AND.VTMP<0.0)THEN
                VELANG=2*PI+ATAN(VTMP/UTMP)
             ELSEIF(UTMP==0.0)THEN
                VELANG=SIGN(0.5d0*PI,VTMP)
             ENDIF
             ! Set Orbital velocity in m/s and waveangle and frequency
             IF(ISWAVE.GT.0)THEN
                 WVFREQ(L)=WVFRQ
                 WVORBIT(L)=SQRT(UWVSQ(L))
                 WVANG(L)=WACCWE(L)
             ELSEIF(ISWNWAVE==1)THEN
                WVANG(L)=WVANGLE
             ENDIF
             ! Calculate wave friction factor
             FWW(L)=2.0*(0.0747*(KN(L)*WVFREQ(L)/WVORBIT(L)))**0.66
             SIGMAWV=FC(L)/FWW(L)*(VELMAG/(WVORBIT(L)*100.0))**2
             MMW=SQRT(1.0+SIGMAWV**2+2.0*SIGMAWV*ABS(COS(VELANG-WVANG(L))))
             JJW=WVORBIT(L)/(KN(L)*WVFREQ(L))*SQRT(MMW*FWW(L)/2.0)
             FWW(L)=MMW*0.15/JJW
             !Calculate wave boundary layer info
             DELW=KN(L)*0.273*SQRT(JJW)
             APROUGH=30.0*DELW*EXP(-5.62*DELW/KN(L)*SQRT(SIGMAWV/MMW))
             !Calculate new current friction factor
             FC(L)=2.0*(1.0/(2.38*LOG(30.0*HP(L)/(2.718*KN(L)))-2.38*LOG(APROUGH/KN(L))))**2
             !Iterate once more
             SIGMAWV=FC(L)/FWW(L)*(VELMAG/(WVORBIT(L)*100.0))**2
             MMW=SQRT(1.0+SIGMAWV**2+2.0*SIGMAWV*ABS(COS(VELANG-WVANG(L))))
             JJW=WVORBIT(L)/(KN(L)*WVFREQ(L))*SQRT(MMW*FWW(L)/2.0)
             FWW(L)=MMW*0.15/JJW
             !Calculate total wave and current shear stress (dynes/cm^2)
             TAU(L)=0.5*FWW(L)*WVORBIT(L)**2*10000.0*MMW
!             TAUB(L)=0.1*TAU(L) !PT: conversion from dynes/cm^2 to Pa Don't overwrite EFDC's total bed shear stress
             USTAR(L)=SQRT(TAUB(L)/1000.0) !only true because USTAR=SQRT(Tau/RhoH2O) and RhoH2O is 1000 kg/cm^3.
          ENDIF
        ENDIF
     ENDDO
     !*****************************

  ELSE !Set constant tau is TAUCONST (dynes/cm^2) is greater than 0
     DO L=2,LA
        TAU(L)=TAUCONST
 !       TAUB(L)=0.1*TAU(L) !Don't overwrtie EFDC's shear stress.
        USTAR(L)=SQRT(TAUB(L)/1000.)
     ENDDO
  ENDIF
  !************************
  RETURN
END SUBROUTINE SEDZLJ_SHEAR


c-----------------------------------------------------------------------
c
c-----------------------------------------------------------------------
c
      parameter  (SIZE = 1008, ILOOP = 100)
      complex  a, w
      real     breal(SIZE), bimag(SIZE), qbreal(SIZE), qbimag(SIZE)
c
      ioutd = i1mach(2)
      nn = SIZE
      tpi = 8.*atan(1.)
      tpion = tpi/float(nn)
      w = cmplx(cos(tpion),-sin(tpion))
c
c generate a**k as test function
c result to b(i) for modification by dft and idft subroutines and
c a copy to qb(i) to compare final result with for error difference.
c
      a = (.9,.3)
      breal(1) = 1.0
      bimag(1) = 0.0
      qbreal(1) = 1.0
      qbimag(1) = 0.0
      do 10 k=2,nn
        w = a**(k-1)
        breal(k) = real(w)
        bimag(k) = aimag(w)
        qbreal(k) = breal(k)
        qbimag(k) = bimag(k)
  10  continue
c
c now compute dft, idft, dft, idft, ...
c first dft is computed specially, in case subroutine needs to be started.
c
      call wfta(breal, bimag, SIZE, 0, 0, ierr)
      do 25 icount = 1, ILOOP
         call wfta(breal, bimag, SIZE, 1, 1, ierr)
         call wfta(breal, bimag, SIZE, 0, 1, ierr)
   25 continue
      call wfta(breal, bimag, SIZE, 1, 1, ierr)
c
c calculate rms error between b(i) and qb(i).
c
      err = 0.
      do 30 i=1,nn
        err = err + (breal(i)-qbreal(i))**2
     *            + (bimag(i)-qbimag(i))**2
  30  continue
      err = sqrt(err / float(nn))
      write (ioutd,9994) ILOOP, err
 9994 format(' rms error, after ', i5, ' loops = ', e15.8)
      stop
      end


      PROGRAM MAIN

C     RESULT REPORTING
C     CHARACTER(LEN=*), PARAMETER  :: FMT1 = "(F18.15)"
      CHARACTER(LEN=*), PARAMETER  :: FMT1 = "(E12.6)"

C     ----------------------------------------------
C     Variables and data for FCUL_ZDH_PA
C     ----------------------------------------------
      DOUBLE PRECISION FCUL_ZTD, FCUL_ZHD, FCUL_ZWD

C     CALL FCUL_ZD_HPA
      CALL FCULZD_HPA(30.67166667D0, 2010.344D0, 798.4188D0,
     . 14.322D0, 0.532D0, FCUL_ZTD, FCUL_ZHD, FCUL_ZWD)
C     REPORT RESULTS
      PRINT *, '----------------------------------------'
      PRINT *, '> FCULZD_HPA  Results:'
      PRINT *, '----------------------------------------'
      WRITE(*, FMT1) DABS(FCUL_ZTD-1.935225924846803114D0)
      WRITE(*, FMT1) DABS(FCUL_ZHD-1.932992176591644462D0)
      WRITE(*, FMT1) DABS(FCUL_ZWD-0.2233748255158703871D-02)

C     ALL DONE
      END


      DOUBLE PRECISION FUNCTION SS(NA,NB,LA1,LB1,M1,UA,UB,R1,FIRST)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      LOGICAL FIRST
      DIMENSION FA(0:13),AFF(0:2,0:2,0:2),AF(0:19),BF(0:19),
     1BI(0:12,0:12)
      DATA AFF/27*0. D0/
      DATA FA/1.D0,1.D0,2.D0,6.D0,24.D0,120.D0,720.D0,5040.D0,40320.D0,
     1362880.D0,3628800.D0,39916800.D0,479001600.D0,6227020800.D0/
      M=M1-1
      LB=LB1-1
      LA=LA1-1
      R=R1/0.529167D0
      IF(FIRST) THEN
         FIRST=.FALSE.
C
C           INITIALISE SOME CONSTANTS
C
C                  BINOMIALS
C
         DO 10 I=0,12
            BI(I,0)=1.D0
            BI(I,I)=1.D0
   10    CONTINUE
         DO 20 I=0,11
            I1=I-1
            DO 20 J=0,I1
               BI(I+1,J+1)=BI(I,J+1)+BI(I,J)
   20    CONTINUE
         AFF(0,0,0)=1.D0
         AFF(1,0,0)=1.D0
         AFF(1,1,0)=1.D0
         AFF(2,0,0)=1.5D0
         AFF(2,1,0)=1.73205D0
         AFF(2,2,0)=1.224745D0
         AFF(2,0,2)=-0.5D0
      ENDIF
      P=(UA+UB)*R*0.5D0
      B=(UA-UB)*R*0.5D0
      EX=EXP(B)
      QUO=1/P
      AF(0)=QUO*EXP(-P)
      DO 30 N=1,19
         AF(N)=N*QUO*AF(N-1)+AF(0)
   30 CONTINUE
      CALL BFN(B,BF)
      SUM=0.D0
      LAM1=LA-M
      LBM1=LB-M
C
C          START OF OVERLAP CALCULATION PROPER
C
      DO 50 I=0,LAM1,2
         IA=NA+I-LA
         IC=LA-I-M
         DO 50 J=0,LBM1,2
            IB=NB+J-LB
            ID=LB-J-M
            SUM1=0.D0
            IAB=IA+IB
            DO 40 K1=0,IA
               DO 40 K2=0,IB
                  DO 40 K3=0,IC
                     DO 40 K4=0,ID
                        DO 40 K5=0,M
                           IAF=IAB-K1-K2+K3+K4+2*K5
                           DO 40 K6=0,M
                              IBF=K1+K2+K3+K4+2*K6
                              JX=(-1)**(M+K2+K4+K5+K6)
                              SUM1=SUM1+BI(ID,K4)*
     1BI(M,K5)*BI(IC,K3)*BI(IB,K2)*BI(IA,K1)*
     2BI(M,K6)*JX*AF(IAF)*BF(IBF)
   40       CONTINUE
            SUM=SUM+SUM1*AFF(LA,M,I)*AFF(LB,M,J)
   50 CONTINUE
      SS=SUM*R**(NA+NB+1)*UA**NA*UB**NB/(2.D0**(M+1))*
     1SQRT(UA*UB/(FA(NA+NA)*FA(NB+NB))*((LA+LA+1)*(LB+LB+1)))
      RETURN
      END


      SUBROUTINE MISES_UMAT(STRESS,STATEV,DDSDDE,SSE,SPD,SCD,
     1 RPL,DDSDDT,DRPLDE,DRPLDT,STRAN,DSTRAN,
     2 TIME,DTIME,TEMP,DTEMP,PREDEF,DPRED,MATERL,NDI,NSHR,NTENS,
     3 NSTATV,PROPS,NPROPS,COORDS,DROT,PNEWDT,CELENT,
     4 DFGRD0,DFGRD1,NOEL,NPT,KSLAY,KSPT,KSTEP,KINC)
C
      INCLUDE 'ABA_PARAM.INC'
C
      CHARACTER*80 MATERL
      DIMENSION STRESS(NTENS),STATEV(NSTATV),
     1 DDSDDE(NTENS,NTENS),DDSDDT(NTENS),DRPLDE(NTENS),
     2 STRAN(NTENS),DSTRAN(NTENS),TIME(2),PREDEF(1),DPRED(1),
     3 PROPS(NPROPS),COORDS(3),DROT(3,3),
     4 DFGRD0(3,3),DFGRD1(3,3)
C
      DIMENSION EELAS(6),EPLAS(6),FLOW(6)
      PARAMETER (ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,SIX=6.0D0)
      DATA NEWTON,TOLER/10,1.D-6/
C
C -----------------------------------------------------------
C     UMAT FOR ISOTROPIC ELASTICITY AND ISOTROPIC PLASTICITY
C     J2 FLOW THEORY
C     CAN NOT BE USED FOR PLANE STRESS
C -----------------------------------------------------------
C     PROPS(1) - E
C     PROPS(2) - NU
C     PROPS(3) - SYIELD
C     CALLS AHARD FOR CURVE OF SYIELD VS. PEEQ
C -----------------------------------------------------------
C
      IF (NDI.NE.3) THEN
         WRITE(6,1)
 1       FORMAT(//,30X,'***ERROR - THIS UMAT MAY ONLY BE USED FOR ',
     1          'ELEMENTS WITH THREE DIRECT STRESS COMPONENTS')
      ENDIF
C
C     ELASTIC PROPERTIES
C
      EMOD=PROPS(1)
      ENU=PROPS(2)
      IF(ENU.GT.0.4999.AND.ENU.LT.0.5001) ENU=0.499
      EBULK3=EMOD/(ONE-TWO*ENU)
      EG2=EMOD/(ONE+ENU)
      EG=EG2/TWO
      EG3=THREE*EG
      ELAM=(EBULK3-EG2)/THREE
C
C     ELASTIC STIFFNESS
C
      DO 20 K1=1,NTENS
        DO 10 K2=1,NTENS
           DDSDDE(K2,K1)=0.0
 10     CONTINUE
 20   CONTINUE
C
      DO 40 K1=1,NDI
        DO 30 K2=1,NDI
           DDSDDE(K2,K1)=ELAM
 30     CONTINUE
        DDSDDE(K1,K1)=EG2+ELAM
 40   CONTINUE
      DO 50 K1=NDI+1,NTENS
        DDSDDE(K1,K1)=EG
 50   CONTINUE
C
C    CALCULATE STRESS FROM ELASTIC STRAINS
C
      DO 70 K1=1,NTENS
        DO 60 K2=1,NTENS
           STRESS(K2)=STRESS(K2)+DDSDDE(K2,K1)*DSTRAN(K1)
 60     CONTINUE
 70   CONTINUE
C
C    RECOVER ELASTIC AND PLASTIC STRAINS
C
      DO 80 K1=1,NTENS
         EELAS(K1)=STATEV(K1)+DSTRAN(K1)
         EPLAS(K1)=STATEV(K1+NTENS)
 80   CONTINUE
      EQPLAS=STATEV(1+2*NTENS)
C
C    IF NO YIELD STRESS IS GIVEN, MATERIAL IS TAKEN TO BE ELASTIC
C
      IF(NPROPS.GT.2.AND.PROPS(3).GT.0.0) THEN
C
C       MISES STRESS
C
        SMISES=(STRESS(1)-STRESS(2))*(STRESS(1)-STRESS(2)) +
     1          (STRESS(2)-STRESS(3))*(STRESS(2)-STRESS(3)) +
     1          (STRESS(3)-STRESS(1))*(STRESS(3)-STRESS(1))
        DO 90 K1=NDI+1,NTENS
              SMISES=SMISES+SIX*STRESS(K1)*STRESS(K1)
 90     CONTINUE
        SMISES=SQRT(SMISES/TWO)
C
C       HARDENING CURVE, GET YIELD STRESS
C
        NVALUE=NPROPS/2-1
        CALL AHARD(SYIEL0,HARD,EQPLAS,PROPS(3),NVALUE)
C
C       DETERMINE IF ACTIVELY YIELDING
C
        IF (SMISES.GT.(1.0+TOLER)*SYIEL0) THEN
C
C         FLOW DIRECTION
C
          SHYDRO=(STRESS(1)+STRESS(2)+STRESS(3))/THREE
          ONESY=ONE/SMISES
          DO 110 K1=1,NDI
             FLOW(K1)=ONESY*(STRESS(K1)-SHYDRO)
 110      CONTINUE
          DO 120 K1=NDI+1,NTENS
             FLOW(K1)=STRESS(K1)*ONESY
 120      CONTINUE
C
C       SOLVE FOR EQUIV STRESS, NEWTON ITERATION
C
          SYIELD=SYIEL0
          DEQPL=0.0
          DO 130 KEWTON=1,NEWTON
             RHS=SMISES-EG3*DEQPL-SYIELD
             DEQPL=DEQPL+RHS/(EG3+HARD)
             CALL AHARD(SYIELD,HARD,EQPLAS+DEQPL,PROPS(3),NVALUE)
             IF(ABS(RHS).LT.TOLER*SYIEL0) GOTO 140
 130      CONTINUE
          WRITE(6,2) NEWTON
 2        FORMAT(//,30X,'***WARNING - PLASTICITY ALGORITHM DID NOT ',
     1        'CONVERGE AFTER ',I3,' ITERATIONS')
 140      CONTINUE
          EFFHRD=EG3*HARD/(EG3+HARD)
C
C       CALC STRESS AND UPDATE STRAINS
C
          DO 150 K1=1,NDI
             STRESS(K1)=FLOW(K1)*SYIELD+SHYDRO
             EPLAS(K1)=EPLAS(K1)+THREE*FLOW(K1)*DEQPL/TWO
             EELAS(K1)=EELAS(K1)-THREE*FLOW(K1)*DEQPL/TWO
 150      CONTINUE
          DO 160 K1=NDI+1,NTENS
             STRESS(K1)=FLOW(K1)*SYIELD
             EPLAS(K1)=EPLAS(K1)+THREE*FLOW(K1)*DEQPL
             EELAS(K1)=EELAS(K1)-THREE*FLOW(K1)*DEQPL
 160      CONTINUE
          EQPLAS=EQPLAS+DEQPL
          SPD=DEQPL*(SYIEL0+SYIELD)/TWO
C
C       JACOBIAN
C
          EFFG=EG*SYIELD/SMISES
          EFFG2=TWO*EFFG
          EFFG3=THREE*EFFG2/TWO
          EFFLAM=(EBULK3-EFFG2)/THREE
          DO 220 K1=1,NDI
             DO 210 K2=1,NDI
                DDSDDE(K2,K1)=EFFLAM
 210         CONTINUE
             DDSDDE(K1,K1)=EFFG2+EFFLAM
 220      CONTINUE
          DO 230 K1=NDI+1,NTENS
             DDSDDE(K1,K1)=EFFG
 230      CONTINUE
          DO 250 K1=1,NTENS
             DO 240 K2=1,NTENS
                DDSDDE(K2,K1)=DDSDDE(K2,K1)+FLOW(K2)*FLOW(K1)
     1                                       *(EFFHRD-EFFG3)
 240         CONTINUE
 250      CONTINUE
        ENDIF
      ENDIF
C
C STORE STRAINS IN STATE VARIABLE ARRAY
C
      DO 310 K1=1,NTENS
        STATEV(K1)=EELAS(K1)
        STATEV(K1+NTENS)=EPLAS(K1)
 310  CONTINUE
      STATEV(1+2*NTENS)=EQPLAS
C
      RETURN
      END
C
C
      SUBROUTINE AHARD(SYIELD,HARD,EQPLAS,TABLE,NVALUE)
C
      INCLUDE 'ABA_PARAM.INC'
      DIMENSION TABLE(2,NVALUE)
C
C    SET YIELD STRESS TO LAST VALUE OF TABLE, HARDENING TO ZERO
      SYIELD=TABLE(1,NVALUE)
      HARD=0.0
C
C   IF MORE THAN ONE ENTRY, SEARCH TABLE
C
      IF(NVALUE.GT.1) THEN
        DO 10 K1=1,NVALUE-1
           EQPL1=TABLE(2,K1+1)
           IF(EQPLAS.LT.EQPL1) THEN
             EQPL0=TABLE(2,K1)
             IF(EQPL1.LE.EQPL0) THEN
                WRITE(6,1)
 1              FORMAT(//,30X,'***ERROR - PLASTIC STRAIN MUST BE ',
     1                 'ENTERED IN ASCENDING ORDER')
                CALL XIT
              ENDIF
C
C           CURRENT YIELD STRESS AND HARDENING
C
            DEQPL=EQPL1-EQPL0
            SYIEL0=TABLE(1,K1)
            SYIEL1=TABLE(1,K1+1)
            DSYIEL=SYIEL1-SYIEL0
            HARD=DSYIEL/DEQPL
            SYIELD=SYIEL0+(EQPLAS-EQPL0)*HARD
            GOTO 20
            ENDIF
 10         CONTINUE
 20         CONTINUE
      ENDIF
      RETURN
      END


! { dg-do run }
! inspired by PR17175
REAL X
DOUBLE PRECISION Y

INTEGER, PARAMETER :: DP = KIND(Y)

INTEGER(kind=1) I1
INTEGER(kind=2) I2
INTEGER(kind=4) I4
INTEGER(kind=8) I8

X = 1.
Y = 1._DP

I1 = 10
I2 = -10
I4 = 20
I8 = -20

X = SCALE (X, I1)
X = SCALE (X, I2)
IF (X.NE.1.) STOP 1
X = SCALE (X, I4)
X = SCALE (X, I8)
IF (X.NE.1.) STOP 2

Y = SCALE (Y, I1)
Y = SCALE (Y, I2)
IF (Y.NE.1._DP) STOP 3
Y = SCALE (Y, I4)
Y = SCALE (Y, I8)
IF (Y.NE.1._DP) STOP 4

END


      SUBROUTINE f90daxpy(a, x, y, n, iters)
      INTEGER n, iters
      DOUBLE PRECISION, DIMENSION (n) :: x, y
      DOUBLE PRECISION a, b

      b = - a

      DO i=1,iters
        y = y + a * x
        y = y + b * x
      END DO
      END SUBROUTINE


module mod_square
  use,intrinsic :: iso_fortran_env
  use mod_wall_clock_time, only : wall_clock_time
  implicit none
  private
  public square
  interface square
    module procedure square_i4,square_r4,square_r8,square_c8
  end interface square

  contains
    !---
    subroutine square_i4(time_do,time_array,n,a,b)
      real(real64),intent(out) :: time_do,time_array
      integer(int32),intent(in) :: n
      integer(int32),dimension(n),intent(inout) :: a,b
      integer(int32) :: i
      real(real64) :: t1,t2

      call wall_clock_time(t1)
      do i=1,n
        a(i) = b(i)**2
      end do
      call wall_clock_time(t2)
      time_do = t2-t1

      call wall_clock_time(t1)
      a(1:n) = b(1:n)**2
      call wall_clock_time(t2)
      time_array = t2-t1

    end subroutine square_i4
    !---
    subroutine square_r4(time_do,time_array,n,a,b)
      real(real64),intent(out) :: time_do,time_array
      integer(int32),intent(in) :: n
      real(real32),dimension(n),intent(inout) :: a,b
      integer(int32) :: i
      real(real64) :: t1,t2

      call wall_clock_time(t1)
      do i=1,n
        a(i) = b(i)**2
      end do
      call wall_clock_time(t2)
      time_do = t2-t1

      call wall_clock_time(t1)
      a(1:n) = b(1:n)**2
      call wall_clock_time(t2)
      time_array = t2-t1

    end subroutine square_r4
    !---
    subroutine square_r8(time_do,time_array,n,a,b)
      real(real64),intent(out) :: time_do,time_array
      integer(int32),intent(in) :: n
      real(real64),dimension(n),intent(inout) :: a,b
      integer(int32) :: i
      real(real64) :: t1,t2

      call wall_clock_time(t1)
      do i=1,n
        a(i) = b(i)**2
      end do
      call wall_clock_time(t2)
      time_do = t2-t1

      call wall_clock_time(t1)
      a(1:n) = b(1:n)**2
      call wall_clock_time(t2)
      time_array = t2-t1

    end subroutine square_r8
    !---
    subroutine square_c8(time_do,time_array,n,a,b)
      real(real64),intent(out) :: time_do,time_array
      integer(int32),intent(in) :: n
      complex(real64),dimension(n),intent(inout) :: a,b
      integer(int32) :: i
      real(real64) :: t1,t2

      call wall_clock_time(t1)
      do i=1,n
        a(i) = b(i)**2
      end do
      call wall_clock_time(t2)
      time_do = t2-t1

      call wall_clock_time(t1)
      a(1:n) = b(1:n)**2
      call wall_clock_time(t2)
      time_array = t2-t1

    end subroutine square_c8
    !---
end module mod_square


program constant_kinds
implicit none

integer, parameter :: i1 = 1
integer, parameter :: i2 = 1_4
integer, parameter :: i3 = 1_8
real, parameter :: r1 = 1.0
real, parameter :: r2 = 1.d0
real, parameter :: r3 = 1.0_4
real, parameter :: r4 = 1.0_8

integer :: x
real :: y

y = 1.0
y = 1.d0
y = 1.0_4
y = 1.0_8
x = 1
x = 1_4
x = 1_8

end program


    program AOC11

    implicit none

    integer :: grid(10,10)
    integer :: step
    integer :: xloc(10), x, y, i, j, flashes
    logical :: chain, mask(10,10)

    open (unit=1, file='input.txt', form='formatted', status='old')
    read (1,'(10I1)') grid
    flashes = 0

    do step=0,99
       !print '("Step ",I3//10(10I1/))',step,grid
        grid = grid + 1
        mask = .true.
        do
            xloc = findloc (grid,10,dim=1,mask=mask)
            if (all((xloc==0),dim=1)) exit
            do y=1,10
                x = xloc(y)
                if (x == 0) cycle
                mask(x,y) = .false.
                grid(x,y) = 0
                flashes = flashes + 1
                do j = y-1,y+1
                    if (j < 1 .or. j > 10) cycle
                    do i = x-1,x+1
                        if (i < 1 .or. i > 10) cycle
                        if ((j == y) .and. (i == x)) cycle
                        if (.not. mask(i,j)) cycle
                        if (grid(i,j) < 10) grid(i,j) = grid(i,j) + 1
                    end do
                end do
            end do
        end do
    end do
   print '("Step ",I3//10(10I1/))',step,grid
    print *, flashes

    end program AOC11


program phaml_master
use phaml
use phaml_user_mod
implicit none
type(phaml_solution_type) :: soln
real(my_real), pointer :: x(:), y(:), u(:)
integer :: i
call phaml_create(soln,nproc=1)
call update_usermod(soln)
call phaml_solve_pde(soln,max_refsolveloop=1,mg_cycles=20)
call phaml_get_grid_soln(soln,x,y,u)
do i=1,size(x)
   write(6,"(SS,1P,3E19.12E2)") x(i),y(i),u(i)
end do
deallocate(x,y,u)
call phaml_destroy(soln)
end program phaml_master


SUBROUTINE FILTERING_SWENSE(Nx,Ny,U,U_I,filterNP,filterALPHA,filtercoefficients,oddeven,GhostGridX,GhostGridY)

USE Precision
USE Constants
IMPLICIT NONE
INTEGER :: Nx, Ny, i, j,k, filterALPHA, filterNP, oddeven, GhostGridX,GhostGridY
REAL(KIND=long) :: U(Nx,Ny), U_I(Nx,Ny), tmp(Nx,Ny), filtercoefficients(filterNP), idx(filterNP)
! test...
REAL(KIND=long) :: filtercoeff_bis(filterNP)

DO k = 1 , 2
  SELECT CASE (MOD(oddeven+k,2))
	CASE (0)
     IF (Nx>1) THEN
	  tmp = U+U_I
	  ! INTERIOR
	  DO j = 1, Ny
		DO i = 1+filterALPHA, Nx-filterALPHA
			U(i,j) = DOT_PRODUCT(tmp(i-filterALPHA:i+filterALPHA,j),filtercoefficients)-U_I(i,j)
		END DO
	  END DO
!$$$$$$       !
!$$$$$$       ! GD : modification, assuming symetry with respect to the boundary...
!$$$$$$       !
!$$$$$$       ! Left
!$$$$$$       DO j = 1, Ny
!$$$$$$         DO i = 1+GhostGridX,1+filterALPHA !keep the 1+filteralpha to prevent from using Ghost point?
!$$$$$$             !U(i,j) = DOT_PRODUCT(tmp(i-filterALPHA:i+filterALPHA,j),filtercoefficients)-U_I(i,j)
!$$$$$$             U(i,j) = DOT_PRODUCT(tmp(filterALPHA+i:2*i-GhostGridX:-1,j),filtercoefficients(1:filterALPHA-(i-GhostGridX)+1)) !points reproduced
!$$$$$$             U(i,j) = U(i,j) + DOT_PRODUCT(tmp(1+GhostGridX:i+filterALPHA,j),filtercoefficients(filterALPHA-(i-GhostGridX)+2:filterNP)) ! points in the domain
!$$$$$$             U(i,j) = U(i,j)-U_I(i,j)
!$$$$$$         END DO
!$$$$$$       END DO
!$$$$$$       ! Right
!$$$$$$       DO j = 1, Ny
!$$$$$$         DO i = Nx-filterALPHA-GhostGridX+1, Nx-GhostGridX !keep the Nx-filterALPHA-GhostGridX to prevent from using Ghost point?
!$$$$$$             U(i,j) = DOT_PRODUCT(tmp(i-filterALPHA:Nx-GhostGridX,j),filtercoefficients(1:Nx-GhostGridX-(i-filterALPHA)+1)) !points in the domain
!$$$$$$             U(i,j) = U(i,j) + DOT_PRODUCT(tmp(Nx-GhostGridX-1:Nx-GhostGridX-1-(filterALPHA-(Nx-i-GhostGridX)-1):-1,j),filtercoefficients(Nx-GhostGridX-(i-filterALPHA)+2:filterNP)) ! points reproduced
!$$$$$$             U(i,j) = U(i,j)-U_I(i,j)
!$$$$$$         END DO
!$$$$$$       END DO

!$$$$$$        !Left
!$$$$$$        DO j = 1+GhostGridY, Ny-GhostGridY
!$$$$$$          DO i = 1+GhostGridX,1+filterALPHA !keep the 1+filteralpha to prevent from using Ghost point?
!$$$$$$            filtercoeff_bis(1:filterNP) = filtercoefficients(1:filterNP)
!$$$$$$            filtercoeff_bis(filterNP:filterNP-(filterALPHA-(i-GhostGridX)+1-1):-1) = filtercoeff_bis(filterNP:filterNP-(filterALPHA-(i-GhostGridX)+1-1):-1) &
!$$$$$$                + filtercoefficients(1:filterALPHA-(i-GhostGridX)+1)
!$$$$$$            ! filtercoeff_bis starts at filterALPHA-(i-GhostGridX)+2
!$$$$$$            U(i,j) = DOT_PRODUCT(tmp(1+GhostGridX:i+filterALPHA,j),filtercoeff_bis(filterALPHA-(i-GhostGridX)+2:filterNP))-U_I(i,j)
!$$$$$$            print*,i,i+filterALPHA-(1+GhostGridX)+1,filterNP-(filterALPHA-(i-GhostGridX)+2)+1
!$$$$$$            print*,i,filterNP-(filterNP-(filterALPHA-(i-GhostGridX)+1-1))+1,filterALPHA-(i-GhostGridX)+1
!$$$$$$          END DO
!$$$$$$        END DO
!$$$$$$        pause
!$$$$$$        ! Right
!$$$$$$         DO j = 1+GhostGridY, Ny-GhostGridY
!$$$$$$           DO i = Nx-filterALPHA-GhostGridX+1, Nx-GhostGridX !keep the Nx-filterALPHA-GhostGridX to prevent from using Ghost point?
!$$$$$$             filtercoeff_bis(1:filterNP) = filtercoefficients(1:filterNP)
!$$$$$$             filtercoeff_bis(1:filterNP-(Nx-GhostGridX-(i-filterALPHA)+2)+1) = filtercoeff_bis(1:filterNP-(Nx-GhostGridX-(i-filterALPHA)+2)+1) &
!$$$$$$                 + filtercoefficients(filterNP:Nx-GhostGridX-(i-filterALPHA)+2:-1)
!$$$$$$             U(i,j) = DOT_PRODUCT(tmp(i-filterALPHA:Nx-GhostGridX,j),filtercoeff_bis(1:Nx-GhostGridX-(i-filterALPHA)+1))-U_I(i,j)
!$$$$$$           END DO
!$$$$$$         END DO
	 ENDIF
	CASE (1)
	  IF (Ny>1) THEN
		tmp = U+U_I
		! INTERIOR
		DO j = 1+filterALPHA, Ny-filterALPHA
			DO i = 1, Nx
				U(i,j) = DOT_PRODUCT(tmp(i,j-filterALPHA:j+filterALPHA),filtercoefficients)-U_I(i,j)
			END DO
		END DO
!$$$$$$         !
!$$$$$$         ! GD : modification, assuming symetry with respect to the boundary...
!$$$$$$         !
!$$$$$$         ! Left
!$$$$$$         DO j = 1+GhostGridY, 1+filterALPHA
!$$$$$$           DO i = 1,Nx !keep the 1+filteralpha to prevent from using Ghost point?
!$$$$$$               U(i,j) = DOT_PRODUCT(tmp(i,filterALPHA+j:2*j-GhostGridY:-1),filtercoefficients(1:filterALPHA-(j-GhostGridY)+1)) !points reproduced
!$$$$$$               U(i,j) = U(i,j) + DOT_PRODUCT(tmp(i,1+GhostGridY:j+filterALPHA),filtercoefficients(filterALPHA-(j-GhostGridY)+2:filterNP)) ! points in the domain
!$$$$$$               U(i,j) = U(i,j)-U_I(i,j)
!$$$$$$           END DO
!$$$$$$         END DO
!$$$$$$         ! Right
!$$$$$$         DO j = Ny-filterALPHA-GhostGridY+1, Ny-GhostGridY !keep the Nx-filterALPHA-GhostGridX to prevent from using Ghost point?
!$$$$$$           DO i = 1, Nx
!$$$$$$               U(i,j) = DOT_PRODUCT(tmp(i,j-filterALPHA:Ny-GhostGridY),filtercoefficients(1:Ny-GhostGridY-(j-filterALPHA)+1)) !points in the domain
!$$$$$$               U(i,j) = U(i,j) + DOT_PRODUCT(tmp(i,Ny-GhostGridY-1:Ny-GhostGridY-1-(filterALPHA-(Ny-j-GhostGridY)-1):-1),filtercoefficients(Ny-GhostGridY-(j-filterALPHA)+2:filterNP)) ! points reproduced
!$$$$$$               U(i,j) = U(i,j)-U_I(i,j)
!$$$$$$           END DO
!$$$$$$         END DO
	  ENDIF
  END SELECT
END DO
PRINT*,'  SG-FILTER applied.'
END SUBROUTINE


!===============================================================================
program CIJ_rotate_euler
!===============================================================================
!  Program calling CIJ_rot_euler

   use anisotropy_ajn, only: CIJ_load, CIJ_rot_euler

   implicit none

   real(8) :: C(6,6), CR(6,6), psi1, phi, psi2, rho
   character(len=250) :: file, arg, type = 'z1x2z3'
   logical :: ecs_from_file = .false., passive = .false.
   integer :: iostatus, i, j

   call get_args

   ! Get elastic constants
   ! if reading from .ecs file, just output in same units: assumes density normalised
   if (ecs_from_file) then
      call CIJ_load(file,C,rho)
      CR = CIJ_rot_euler(C, psi1, phi, psi2, type=type, passive=passive)
      write(*,*) CR
   ! Otherwise, we're reading several constants from stdin
   else
      iostatus = 0
      do while (iostatus == 0)
         read(*,*,iostat=iostatus) ((C(i,j),j=1,6),i=1,6)
         if (iostatus < 0) exit
         if (iostatus > 0) then
            write(0,'(a)') 'CIJ_rot_euler: problem reading 36 input elastic constants from stdin.'
            stop
         endif
         CR = CIJ_rot_euler(C, psi1, phi, psi2, type=type, passive=passive)
         write(*,*) CR
      enddo
   endif

contains
   subroutine get_args()
      integer :: iarg, narg
      narg = command_argument_count()
      if (narg < 3) call usage
      iarg = 1
      do while (iarg <= narg - 3)
         call get_command_argument(iarg, arg)
         select case(arg)
            case('-f')
               ecs_from_file = .true.
               call get_command_argument(iarg+1, file)
               iarg = iarg + 2
            case('-p')
               passive = .true.
               iarg = iarg + 1
            case('-t')
               call get_command_argument(iarg+1, type)
               iarg = iarg + 2
            case default
               write(0,'(a)') 'CIJ_rotate_euler: Error: unrecognised option "'//trim(arg)//'"'
               stop
         end select
      enddo
      if (narg - iarg /= 2) call usage
      call get_command_argument(narg-2, arg)
      read(arg,*,iostat=iostatus) psi1
      if (iostatus /= 0) then
         write(0,'(a)') 'CIJ_rot_euler: Error: Problem getting psi1 from command line'
         stop
      endif
      call get_command_argument(narg-1, arg)
      read(arg,*,iostat=iostatus) phi
      if (iostatus /= 0) then
         write(0,'(a)') 'CIJ_rot_euler: Error: Problem getting phi from command line'
         stop
      endif
      call get_command_argument(narg, arg)
      read(arg,*,iostat=iostatus) psi2
      if (iostatus /= 0) then
         write(0,'(a)') 'CIJ_rot_euler: Error: Problem getting psi2 from command line'
         stop
      endif
   end subroutine get_args

   subroutine usage()
      write(0,'(a)') &
         'Usage: CIJ_rot_euler (options) [psi1] [phi] [psi2]', &
         '  Rotations are applied anticlockwise about z1,x2,z3 axes looking down axis.',&
         '  ECs are read from stdin, 36 constants per line, unless the -f option is used.', &
         'Options:', &
         '   -f [file]  : Read ECs from .ecs file [stdin]', &
         '   -p         : Apply passive rotation', &
         '   -t [type]  : Apply rotation in different convention.  Type must be a six-character', &
         '                combination of axes.  The default is z1x2z3, corresponding to rotation', &
         '                first about the original z axis, then the new x axis, then the new z', &
         '                z axis.'
      stop
   end subroutine usage
end program CIJ_rotate_euler
!-------------------------------------------------------------------------------