      subroutine ch_ttcoef(k)

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    this subroutine computes travel time coefficients for routing
!!    along the main channel

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    ch_d(:)     |m             |average depth of main channel
!!    ch_n(2,:)   |none          |Manning"s "n" value for the main channel
!!    ch_s(2,:)   |m/m           |average slope of main channel
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ OUTGOING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    chsslope(:)   |none          |change in horizontal distance per unit
!!                               |change in vertical distance on channel side
!!                               |slopes; always set to 2 (slope=1/2)
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ LOCAL DEFINITIONS ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    aa          |none          |area/area=1 (used to calculate velocity with
!!                               |Manning"s equation)
!!    a           |m^2           |cross-sectional area of channel
!!    b           |m             |bottom width of channel
!!    d           |m             |depth of flow
!!    fps         |none          |change in horizontal distance per unit
!!                               |change in vertical distance on floodplain side
!!                               |slopes; always set to 4 (slope=1/4)
!!    jj          |none          |counter
!!    k           |none          |dummy argument (HRU number)
!!    p           |m             |wetting perimeter
!!    qq1         |m^3/s         |flow rate for a specified depth
!!    rh          |m             |hydraulic radius of channel
!!    tt1         |km s/m        |time coefficient for specified depth
!!    tt2         |km s/m        |time coefficient for bankfull depth
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ SUBROUTINES/FUNCTIONS CALLED ~ ~ ~
!!    Intrinsic: Sqrt
!!    SWAT: Qman

!!    ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~

      use channel_data_module
      use channel_module
      use channel_velocity_module

      implicit none

      integer, intent (in) :: k  !none          |dummy argument (HRU number)
      integer :: jj              !none          |counter
      real :: fps                !none          |change in horizontal distance per unit
                                 !              |change in vertical distance on floodplain side
                                 !              |slopes; always set to 4 (slope=1/4)
      real :: d                  !m             |depth of flow
      real :: b                  !m             |bottom width of channel
      real :: p                  !m             |wetting perimeter
      real :: a                  !m^2           |cross-sectional area of channel
      real :: qq1                !m^3/s         |flow rate for a specified depth
      real :: rh                 !m             |hydraulic radius of channel
      real :: tt1                !km s/m        |time coefficient for specified depth
      real :: tt2                !km s/m        |time coefficient for bankfull depth
      real :: aa                 !none          |area/area=1 (used to calculate velocity with
                                 !              |Manning"s equation)
      real :: chsslope           !none          |change in horizontal distance per unit
                                 !              |change in vertical distance on channel side
                                 !              |slopes; always set to 2 (slope=1/2)
      real :: qman               !m^3/s or m/s  |flow rate or flow velocity

      aa = 1.
      b = 0.
      d = 0.
!!    If side slope is not set in .rte file then assume this default
!!    If it is main reach default side slope to 2:1 if it is a waterway default to 8:1
      if (ch_hyd(k)%side <= 1.e-6) then
         chsslope = 2.
      else
         chsslope = ch_hyd(k)%side
      end if

      fps = 4.
      d = ch_hyd(k)%d
      b = ch_hyd(k)%w - 2. * d * chsslope

!!    check if bottom width (b) is < 0
      if (b <= 0.) then
        b = 0.
        chsslope = 0.
        b = .5 * ch_hyd(k)%w
        b = Max(0., b)
        chsslope = (ch_hyd(k)%w - b) / (2. * d)
      end if
      ch_vel(k)%wid_btm = b
      ch_vel(k)%dep_bf = d

!!    compute flow and travel time at bankfull depth
      p = 0.
      a = 0.
      rh = 0.
      tt2 = 0.
      p = b + 2. * d * Sqrt(chsslope * chsslope + 1.)
      a = b * d + chsslope * d * d
      rh = a / p
      ch_vel(k)%area = a
      ch_vel(k)%vel_bf = Qman(a, rh, ch_hyd(k)%n, ch_hyd(k)%s)
      ch_vel(k)%velav_bf = Qman(aa, rh, ch_hyd(k)%n, ch_hyd(k)%s)
      ch_vel(k)%celerity_bf = ch_vel(k)%velav_bf * 5. / 3.
      ch_vel(k)%st_dis = ch_hyd(k)%l / ch_vel(k)%celerity_bf / 3.6
      tt2 = ch_hyd(k)%l * a / ch_vel(k)%vel_bf

!!    compute flow and travel time at 1.2 bankfull depth
      d = 0.
      rh = 0.
      qq1 = 0.
      tt1 = 0.
      d = 1.2 * ch_hyd(k)%d
      a = a + (ch_hyd(k)%w * ch_hyd(k)%d + fps * (d - ch_hyd(k)%d) ** 2)
      p = p + 4. * ch_hyd(k)%w + (0.4 * ch_hyd(k)%d * Sqrt(fps * fps + 1.))
      rh = a / p
      qq1 = Qman(a, rh, ch_hyd(k)%n, ch_hyd(k)%s)
      tt1 = ch_hyd(k)%l * a / qq1

!!    compute flow and travel time at 0.1 bankfull depth
      a = 0.
      d = 0.
      p = 0.
      rh = 0.
      qq1 = 0.
      tt1 = 0.
      d = 0.1 * ch_hyd(k)%d
      p = b + 2. * d * Sqrt(chsslope * chsslope + 1.)
      a = b * d + chsslope * d * d
      rh = a / p
      qq1 = Qman(a, rh, ch_hyd(k)%n, ch_hyd(k)%s)
      tt1 = ch_hyd(k)%l * a / qq1
      ch_vel(k)%vel_1bf = Qman(aa, rh, ch_hyd(k)%n, ch_hyd(k)%s)
      ch_vel(k)%celerity_1bf = ch_vel(k)%vel_1bf * 5. / 3.
      ch_vel(k)%stor_dis_1bf = ch_hyd(k)%l / ch_vel(k)%celerity_1bf / 3.6

      return
      end subroutine ch_ttcoef


subroutine prepare_noise()

USE DFPORT

real hist(2,100),ahist(1000)
character*1 it_ini
integer*2 k12,k22,k32,k42

common/histo/istep,xconv(2000),xdir1,xdir2,dxdir
common/noise_1/a_rand(2),xmid(2)

!******************************************************************
kod_ini1_mod2=1
nhistog=60
nsample=10000

call gettim(k12,k22,k32,k42)
k4=k42
CALL SRAND(k4)

open(1,file='SET.DAT')
read(1,*)a_rand_p, a_rand_s
read(1,*)xmid(1), xmid(2)
close(1)

open(1,file='../../../COMMON/noise_histo.dat',status='old',err=221)
! Read histogram of noise distribution:
read(1,*)nconvert
read(1,*)ds
do i=1,100
	read(1,*,end=1)hist(1,i),hist(2,i)
end do
pause ' Warning: nhist > 100'
1 nhist=i-1
close(1)
goto 222
221 write(*,*)' file COMMON/noise_histo.dat does not exist'
write(*,*)' create this file or use the option "2" for the noise type'
stop
222 continue

write(*,*)' nconvert=',nconvert,' nhist=',nhist
write(*,*)' Noise: amp=',a_rand(1),a_rand(2)

amax=0
do i=1,nhist
	if(hist(2,i).gt.amax) amax=hist(2,i)
end do

xdir1=0
xdir2=1
dxdir0=(xdir2-xdir1)/nconvert

! Integration

sum=0
do i=1,nhist-1
	x1=hist(1,i)
	y1=hist(2,i)
	x2=hist(1,i+1)
	y2=hist(2,i+1)
	sum=sum+(x2-x1)*(y1+y2)/2
end do

!write(*,*)' sum=',sum

porog=sum/nconvert

istep=1

xconv(istep)=hist(1,1)

dsum=0
do i=1,nhist-1
	x1=hist(1,i)
	x2=hist(1,i+1)
	y1=hist(2,i)
	y2=hist(2,i+1)
	nstep=(x2-x1)/ds
	dss=(x2-x1)/nstep
	dydx=(y2-y1)/(x2-x1)
	x3=x1
	y3=y1
	do ii=1,nstep
		x4=x3+dss
		y4=y1+dydx*(x4-x1)
		dsum=dsum+(x4-x3)*(y4+y3)/2
		x3=x4
		y3=y4

		if(dsum.lt.porog) cycle

		!write(*,*)' x4=',x4,' dsum=',dsum,' porog=',porog
		istep=istep+1
		xconv(istep)=x4
		dsum=0
	end do
end do
istep=istep+1
xconv(istep)=hist(1,nhist)

dxdir=(xdir2-xdir1)/(istep-1)

a_rand(1)=1

disp=0
do i=1,nsample
	a=our_noise(1)
	disp=disp+abs(a)
end do
disp=disp/nsample
!write(*,*)' disp P=',disp

a_rand(1)=a_rand_p/disp

amin=-a_rand_p*4
amax=a_rand_p*4
dhistog=(amax-amin)/nhistog

disp=0
ahist=0
do i=1,nsample
    a=our_noise(1)
    disp=disp+abs(a)
    if((a-amin)*(a-amax).gt.0) cycle
    do ih=1,nhistog
        a1=amin+(ih-1)*dhistog
        a2=amin+(ih)*dhistog
        if((a-a1)*(a-a2).le.0.)exit
    end do
    ahist(ih)=ahist(ih)+1
end do
disp=disp/nsample
write(*,*)' disp P=',disp

open(11,file='data_out/hist_p.bln')
write(11,*)nhistog
do ih=1,nhistog
    ah=amin+(ih-0.5)*dhistog
    values=ahist(ih)*100/nsample
    !write(*,*)ih,ah,ahist(ih)
    write(11,*)ah,values
enddo
close(11)

!*****************************************************

a_rand(2)=1
disp=0
do i=1,nsample
    a=our_noise(2)
    disp=disp+abs(a)
end do
disp=disp/nsample
!write(*,*)' disp S=',disp

a_rand(2)=a_rand_s/disp

amin=-a_rand_s*4
amax=a_rand_s*4
dhistog=(amax-amin)/nhistog
!write(*,*)' amin=',amin,' amax=',amax,' nhistog=',nhistog,' dhistog=',dhistog

disp=0
ahist=0
do i=1,nsample
    a=our_noise(2)
    disp=disp+abs(a)
    if((a-amin)*(a-amax).gt.0) cycle
    do ih=1,nhistog
        a1=amin+(ih-1)*dhistog
        a2=amin+(ih)*dhistog
        if((a-a1)*(a-a2).le.0.)exit
    end do
    ahist(ih)=ahist(ih)+1
    !if(ih.eq.41) write(*,*)a
end do

open(11,file='data_out/hist_s.bln')
write(11,*)nhistog
do ih=1,nhistog
    ah=amin+(ih-0.5)*dhistog
    values=ahist(ih)*100/nsample
    !write(*,*)ih,ah,ahist(ih)
    write(11,*)ah,values
enddo
close(11)
disp=disp/nsample
write(*,*)' disp S=',disp

return
end


! ##################################################################################################################################
! Begin MIT license text.
! _______________________________________________________________________________________________________

! Copyright 2019 Dr William R Case, Jr (dbcase29@gmail.com)

! Permission is hereby granted, free of charge, to any person obtaining a copy of this software and
! associated documentation files (the "Software"), to deal in the Software without restriction, including
! without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to
! the following conditions:

! The above copyright notice and this permission notice shall be included in all copies or substantial
! portions of the Software and documentation.

! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
! OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
! THE SOFTWARE.
! _______________________________________________________________________________________________________

! End MIT license text.

      SUBROUTINE CALC_PHIZL

! Merges matrices to get L-set displ transfer matrix:

!            PHIZL    = [ PHIZL1  |  PHIZL2  |  DLR ]
! where
!            PHIZL1   = -KLL(-1)*(MLR + MLL*DLR)
! and
!            PHIZL2   = -EIGEN_VEC*diag(EIGEN_VAL)

! For a description of Craig-Bamptom analyses, see Appendix D to the MYSTRAN User's Referance Manual

      USE PENTIUM_II_KIND, ONLY       :  BYTE, LONG, DOUBLE
      USE IOUNT1, ONLY                :  WRT_ERR, WRT_LOG, ERR, F04, F06
      USE SCONTR, ONLY                :  BLNK_SUB_NAM, FATAL_ERR, NDOFL, NDOFR,                                                    &
                                         NTERM_DLR, NTERM_PHIZL, NTERM_PHIZL1, NTERM_PHIZL2 , NTERM_MLL, NTERM_MLR, NTERM_MRL,     &
                                         NUM_CB_DOFS, NVEC
      USE CONSTANTS_1, ONLY           :  ONE
      USE PARAMS, ONLY                :  PRTPHIZL, SPARSTOR
      USE TIMDAT, ONLY                :  TSEC
      USE EIGEN_MATRICES_1, ONLY      :  EIGEN_VEC, EIGEN_VAL
      USE SPARSE_MATRICES, ONLY       :  SYM_MLL, SYM_MLR, SYM_MRL, SYM_KLL, SYM_DLR, SYM_PHIZL  , SYM_PHIZL1  , SYM_PHIZL2

      USE SPARSE_MATRICES, ONLY       :  I_MLL   , J_MLL   , MLL   , I_MLR   , J_MLR   , MLR   , I_MRL   , J_MRL   , MRL,          &
                                         I_KLL   , J_KLL   , KLL   , I_DLR   , J_DLR   , DLR   ,                                   &
                                         I_PHIZL , J_PHIZL , PHIZL , I_PHIZL1, J_PHIZL1, PHIZL1, I_PHIZL2, J_PHIZL2, PHIZL2

      USE SCRATCH_MATRICES, ONLY      :  I_CRS1, J_CRS1, CRS1, I_CRS2, J_CRS2, CRS2, I_CRS3, J_CRS3, CRS3, I_CCS1, J_CCS1, CCS1

      USE SUBR_BEGEND_LEVELS, ONLY    :  CALC_PHIZL_BEGEND

      USE CALC_PHIZL_USE_IFs

      IMPLICIT NONE

      CHARACTER(LEN=LEN(BLNK_SUB_NAM)):: SUBR_NAME = 'CALC_PHIZL'

      INTEGER(LONG)                   :: AROW_MAX_TERMS    ! Output from MATMULT_SFS_NTERM and input to MATMULT_SFS
      INTEGER(LONG)                   :: I,J               ! DO loop indices
      INTEGER(LONG)                   :: NTERM_CRS1        ! Number of terms in matrix CRS1
      INTEGER(LONG)                   :: NTERM_CRS2        ! Number of terms in matrix CRS2
      INTEGER(LONG)                   :: NTERM_CRS3        ! Number of terms in matrix CRS3
      INTEGER(LONG), PARAMETER        :: SUBR_BEGEND = CALC_PHIZL_BEGEND

      REAL(DOUBLE)                    :: DUM1(NDOFL,NVEC)  ! Intermediate matrix
      REAL(DOUBLE)                    :: SMALL             ! A number used in filtering out small numbers from a full matrix

! **********************************************************************************************************************************
      IF (WRT_LOG >= SUBR_BEGEND) THEN
         CALL OURTIM
         WRITE(F04,9001) SUBR_NAME,TSEC
 9001    FORMAT(1X,A,' BEGN ',F10.3)
      ENDIF

! **********************************************************************************************************************************
! Part 1: Calculate PHIZL1 = -KLL(-1)*(MLR + MLL*DLR). Use CRS3 to hold (MLR + MLL*DLR)
! -------------------------------------------------------------------------------------

      NTERM_MLR = NTERM_MRL
      CALL ALLOCATE_SPARSE_MAT ( 'MLR', NDOFL, NTERM_MLR, SUBR_NAME )
      IF (NTERM_MLR > 0) THEN                              ! Transpose MRL to get MLR

         CALL MATTRNSP_SS ( NDOFR, NDOFL, NTERM_MRL, 'MRL', I_MRL, J_MRL, MRL, 'MLR', I_MLR, J_MLR, MLR )

      ENDIF

      IF (NTERM_MLL > 0) THEN                              ! There will be term MLL*DLR in CRS3
                                                           ! Put DLR into CCS format in array CCS1
         CALL ALLOCATE_SCR_CCS_MAT ( 'CCS1', NDOFR, NTERM_DLR, SUBR_NAME )
         CALL SPARSE_CRS_SPARSE_CCS ( NDOFL, NDOFR, NTERM_DLR, 'DLR', I_DLR, J_DLR, DLR, 'CCS1', J_CCS1, I_CCS1, CCS1, 'Y' )

                                                           ! Sparse multiply to get CRS1 = MLL*DLR = MLL*CCS1
!                                                            (note: use SYM_DLR for sym indicator for CCS1)
         CALL MATMULT_SSS_NTERM ( 'MLL' , NDOFL, NTERM_MLL , SYM_MLL, I_MLL, J_MLL,                                                &
                                  'DLR' , NDOFR, NTERM_DLR , SYM_DLR, J_CCS1, I_CCS1, AROW_MAX_TERMS,                              &
                                  'CRS1',        NTERM_CRS1 )

         CALL ALLOCATE_SCR_CRS_MAT ( 'CRS1', NDOFL, NTERM_CRS1, SUBR_NAME )

         CALL MATMULT_SSS ( 'MLL' , NDOFL, NTERM_MLL , SYM_MLL, I_MLL , J_MLL , MLL,                                               &
                            'DLR' , NDOFR, NTERM_DLR , SYM_DLR, J_CCS1, I_CCS1, CCS1, AROW_MAX_TERMS,                              &
                            'CRS1', ONE  , NTERM_CRS1,          I_CRS1, J_CRS1, CRS1 )

         CALL DEALLOCATE_SCR_MAT ( 'CCS1' )

         IF (NTERM_MLR > 0) THEN                           ! Sparse add to get CRS3 = MLR + MLL*DLR = MLR + CRS1

            CALL MATADD_SSS_NTERM ( NDOFL, 'MLR', NTERM_MLR, I_MLR, J_MLR, SYM_MLR, 'MLL*DLR', NTERM_CRS1, I_CRS1, J_CRS1, 'N',    &
                                   'CRS3', NTERM_CRS3 )
            CALL ALLOCATE_SCR_CRS_MAT ( 'CRS3', NDOFL, NTERM_CRS3, SUBR_NAME )
            CALL MATADD_SSS ( NDOFL, 'MLR', NTERM_MLR, I_MLR, J_MLR, MLR, ONE, 'MLL*DLR', NTERM_CRS1, I_CRS1, J_CRS1, CRS1, ONE,   &
                             'CRS3', NTERM_CRS3, I_CRS3, J_CRS3, CRS3 )

         ELSE                                              ! MLL > 0 but MLR = 0 so set CRS3 to CRS1 (which is MLL*DLR)

            NTERM_CRS3 = NTERM_CRS1
            CALL ALLOCATE_SCR_CRS_MAT ( 'CRS3', NDOFL, NTERM_CRS3, SUBR_NAME )
            DO I=1,NDOFL+1
               I_CRS3(I) = I_CRS1(I)
            ENDDO
            DO I=1,NTERM_CRS3
               J_CRS3(I) = J_CRS1(I)
                 CRS3(I) =   CRS1(I)
            ENDDO

         ENDIF

         CALL DEALLOCATE_SCR_MAT ( 'CRS1' )

      ELSE                                                 ! MLL = 0 so check MLR

         IF (NTERM_MLR > 0) THEN                           ! CRS3 = MLR

            NTERM_CRS3 = NTERM_MLR
            CALL ALLOCATE_SCR_CRS_MAT ( 'CRS3', NDOFL, NTERM_CRS3, SUBR_NAME )
            DO I=1,NDOFL+1
               I_CRS3(I) = I_MLR(I)
            ENDDO
            DO I=1,NTERM_CRS3
               J_CRS3(I) = J_MLR(I)
                 CRS3(I) =   MLR(I)
            ENDDO

         ELSE                                              ! CRS3 = 0 so PHIZL1 = 0

            NTERM_CRS3 = 0

         ENDIF

      ENDIF

! Now solve for PHIZL1

      IF (NTERM_CRS3 > 0) THEN                             ! CRS3 = MLR + MLL*DLR > 0 so solve KLL*PHIZL1 = CRS3 for PHIZL1
         CALL SOLVE_PHIZL1 ( NTERM_CRS3 )
      ELSE
         NTERM_PHIZL1 = 0
      ENDIF
!xx   CALL ALLOCATE_SPARSE_MAT ( 'PHIZL1', NDOFL, NTERM_PHIZL1, SUBR_NAME )

      CALL DEALLOCATE_SCR_MAT ( 'CRS3' )

! Part 2: Calculate PHIZL2 = -EIGEN_VEC*diag(EIGEN_VAL)
! -----------------------------------------------------

      DO I=1,NDOFL                                         ! 1st calc full matrix with PHIZL2 terms
         DO J=1,NVEC
            DUM1(I,J) = -EIGEN_VEC(I,J)/EIGEN_VAL(J)
         ENDDO
      ENDDO
                                                           ! Now convert to sparse format
      CALL CNT_NONZ_IN_FULL_MAT ( 'PHIZL2', DUM1, NDOFL, NVEC, 'N', NTERM_PHIZL2, SMALL )
      CALL ALLOCATE_SPARSE_MAT ( 'PHIZL2', NDOFL, NTERM_PHIZL2, SUBR_NAME )
      CALL FULL_TO_SPARSE_CRS ( '-EIGEN_VEC*diag(EIGEN_VAL)', NDOFL, NVEC, DUM1, NTERM_PHIZL2, SMALL, SUBR_NAME, 'N',              &
                                 I_PHIZL2, J_PHIZL2, PHIZL2 )

! Part 3: Merge PHIZL1 and PHIZL2 into CRS2
! -------------------------------------

      NTERM_CRS2 = NTERM_PHIZL1 + NTERM_PHIZL2

      CALL ALLOCATE_SCR_CRS_MAT ( 'CRS2', NDOFL, NTERM_CRS2, SUBR_NAME )

      CALL MERGE_MAT_COLS_SSS   ( 'PHIZL1', NTERM_PHIZL1, I_PHIZL1, J_PHIZL1, PHIZL1, SYM_PHIZL1, NDOFR,                           &
                                  'PHIZL2', NTERM_PHIZL2, I_PHIZL2, J_PHIZL2, PHIZL2, SYM_PHIZL2, NDOFL,                           &
                                  'CRS2',             I_CRS2, J_CRS2, CRS2, 'N'        )

! Part 4: Merge CRS2 (= PHIZL1, PHIZL2)  with DLR to get final PHIZL
! ------------------------------------------------------------

      NTERM_PHIZL = NTERM_CRS2 + NTERM_DLR

      CALL ALLOCATE_SPARSE_MAT ( 'PHIZL', NDOFL, NTERM_PHIZL, SUBR_NAME )

      CALL MERGE_MAT_COLS_SSS  ( 'CRS2', NTERM_CRS2, I_CRS2, J_CRS2, CRS2, 'N'     , NDOFR+NVEC,                                   &
                                 'DLR' , NTERM_DLR , I_DLR , J_DLR , DLR , SYM_DLR , NDOFL,                                        &
                                 'PHIZL' ,             I_PHIZL , J_PHIZL , PHIZL , 'N'        )

      CALL DEALLOCATE_SCR_MAT ( 'CRS2' )

      IF (PRTPHIZL > 0) THEN
         CALL WRITE_SPARSE_CRS ( 'PHIZL','  ','  ', NTERM_PHIZL, NDOFL, I_PHIZL, J_PHIZL, PHIZL )
      ENDIF

! Part 5: Deallocate PHIZL1 and PHIZL2

      CALL DEALLOCATE_SPARSE_MAT ( 'PHIZL1' )
      CALL DEALLOCATE_SPARSE_MAT ( 'PHIZL2' )

! **********************************************************************************************************************************
      IF (WRT_LOG >= SUBR_BEGEND) THEN
         CALL OURTIM
         WRITE(F04,9002) SUBR_NAME,TSEC
 9002    FORMAT(1X,A,' END  ',F10.3)
      ENDIF

      RETURN

! **********************************************************************************************************************************
  932 FORMAT(' *ERROR   932: PROGRAMMING ERROR IN SUBROUTINE ',A                                                                   &
                    ,/,14X,' PARAMETER SPARSTOR MUST BE EITHER "SYM" OR "NONSYM" BUT VALUE IS ',A)

! **********************************************************************************************************************************

      END SUBROUTINE CALC_PHIZL


program test
   ! Test that sw_misfit_ecs gives the correct answers
   use spherical_geometry, only: sphere_sample
   use splitwave
   use anisotropy_ajn, only: CIJ_phase_vels, CIJ_rot3
   implicit none

   ! Constants for olivine (Abramson)
   integer, parameter :: rs = 8
   real(rs) :: Col(6,6) = 1.e7_8 * reshape( (/ &
        9.5529_8,  2.0298_8,  2.1341_8,      0._8,      0._8,      0._8, &
        2.0298_8,  5.8569_8,  2.2891_8,      0._8,      0._8,      0._8, &
        2.1341_8,  2.2891_8,  6.9598_8,      0._8,      0._8,      0._8, &
            0._8,      0._8,      0._8,  1.9076_8,      0._8,      0._8, &
            0._8,      0._8,      0._8,      0._8,  2.2951_8,      0._8, &
            0._8,      0._8,      0._8,      0._8,      0._8,  2.3457_8/), (/6,6/))
   real(rs) :: rho_ol = 3355._rs
   real(rs) :: vs1, vs2, a, b, c
   real(rs), allocatable :: lon(:), lat(:), phi(:), dt(:), spol(:), &
                            phi_ecs(:), dt_ecs(:), misfit(:)
   integer :: i, n, time(8), size_rand
   integer, allocatable :: seed(:)
   real(rs) :: d = 10._rs, &  ! Spacing of points on sphere
               t = 500._rs,&  ! Layer thickness
               t_scaled       ! Scaled layer thickness from sw_misfit_ecs

   ! Sample the sphere evenly
   call sphere_sample(d, lon, lat, n)
   write(*,'(a,i0.0,a)') 'Testing with ', n, ' orientations'
   allocate(phi(n), dt(n), spol(n), phi_ecs(n), dt_ecs(n), misfit(n))

   ! Compute splits for these orientations
   do i=1,n
      call CIJ_phase_vels(Col, lon(i), lat(i), pol=phi(i), vs1=vs1, vs2=vs2)
      dt(i) = t*(1._rs/vs2 - 1._rs/vs1)
   enddo

   ! Assign random spol
   call random_seed(size=size_rand)
   allocate(seed(size_rand))
   call date_and_time(values=time)  ! Values are y,m,d,zone,h,m,s,msec
   seed = time(8)
   call random_seed(put=seed)      ! Seed with total of values
   call random_number(spol)
   spol = 180._rs * spol

   ! Compare these splits with those predicted in sw_misfit_ecs
   call sw_misfit_ecs(Col, lon, lat, phi, dt, spol, misfit, phi_ecs=phi_ecs, &
      dt_ecs=dt_ecs, t_scaled=t_scaled)
   write(*,'(a,f10.8)') '   Mean misfit v. self: ', sum(misfit)/size(misfit)
   write(*,'(a,f10.2)') '   Scaled thickness: ',t_scaled

   ! Now compare with olivine tensor rotated randomly
   call random_seed()
   call random_number(a)
   a = 360._rs*a
   call random_number(b)
   b = 360._rs*b
   call random_number(c)
   c = 360._rs*c
   call CIJ_rot3(Col, a, b, c, Col)
   call sw_misfit_ecs(Col, lon, lat, phi, dt, spol, misfit, phi_ecs=phi_ecs, &
      dt_ecs=dt_ecs, t_scaled=t_scaled)
   write(*,'(a,f10.8)') '   Mean misfit v. rand: ',sum(misfit)/size(misfit)
   write(*,'(a,f10.2)') '   Scaled thickness: ',t_scaled

   deallocate(lon, lat, phi, dt, spol, phi_ecs, dt_ecs, misfit)

end program test


program main
    use plantFEM
	implicit none

    type(FEMDomain_)::domain
    type(DiffusionEq_)::DiffusionEq
    type(LinearSolver_)::LinearSolver

    ! 領域 を　読み込む（ファイル名）
    call domain%import(node=.true.,file="./Node.txt")
    call domain%import(element=.true.,file="./Element.txt")

    ! 一次元定常拡散方程式について、有限要素法で離散化した連立方程式を作り、ソルバーにセットする。
    !LinearSolver = DiffusionEq%GetEquations(domain)

    ! ソルバーを使って、連立方程式を解く。
    !call LinearSolver%solve(Solver="BiCGSTAB",CRS=.true.)

    ! 結果を表示する。
    !print *, LinearSolver%x(:)

end program main


C************************************************************************
C
C     Subroutine RFT2CH
C
C     Purpose:  To compute 1-D and 2-D real FFT's in core.
C     RFT2CH calls RFT2, DFFT, and REALTR.
C
C     25 JUN 93   T. L. Truong   PORTED TO UNIX
C     10 OCT 83    ...CCA...     CONVERT TO VAX
C     5 MAR 79    ...JJL...      INITIAL RELEASE
c 15-Jan-2013  ...lwk... fixed continued CHARACTER constant for new compiler flag on Solaris
C
C************************************************************************

      SUBROUTINE RFT2CH (BUF,M,N,MODE)
      REAL*4 BUF(*)
C
C ...Where   M     is the number of lines in the data matrix to be transformed
C            N     is the number of samples in data matrix to be transformed
C            MODE  is the direction of the transform, 1(direct) or -1(inverse)
C            BUF   is a buffer containing the data to be transformed
C
      IF(M.GT.1) GO TO 10
      K=N/2
      IF(N.NE.K*2) GO TO 1
      IF(MODE.LT.0) GO TO 11
C****************************
C  DIRECT REAL 1-D FFT
C****************************
      CALL DFFT(BUF(1),BUF(2),K,K,K,2,*1,*2)
      CALL REALTR(BUF(1),BUF(2),K,2)
      RETURN
C****************************
C  INVERSE REAL 1-D FFT
C****************************
11    CONTINUE
      CALL REALTR(BUF(1),BUF(2),K,-2)
      CALL DFFT(BUF(1),BUF(2),K,K,K,-2,*1,*2)
      RETURN
10    CONTINUE
C****************************
C  REAL 2-D FFT DIRECT AND INVERSE
C****************************
      CALL RFT2(BUF,M,N,MODE,ISTATUS)

      IF (ISTATUS.NE.1) THEN
       IF (ISTATUS.EQ.1) GOTO 1
       IF (ISTATUS.EQ.2) GOTO 2
       IF (ISTATUS.EQ.3) GOTO 3
      ENDIF

      RETURN
C****************************
C  PRINT ERROR MESSAGES
C****************************
1     CALL QPRINT(
     +  '0A PRIME FACTOR OF M OR N EXCEEDS 23, RFT2 ABEND',48)
      CALL ABEND
2     CALL QPRINT('0THE PRODUCT OF THE SQUARE-FREE FACTORS OF M OR N IS TOO LARGE, RFT2 ABEND',75)
      CALL ABEND
3     CALL QPRINT('0M IS ODD, RFT2 ABEND',21)
      CALL ABEND
      RETURN
      END


! Program to simulate Plummer's sphere (Leapfrog integrator)
!! Written by Ashwin Nayak
!! Compile with -fdefault-real-8 (gfortran) or -real_size=64 (icc)
!! Last Update: 25-feb-2017
! ---------------------------------------------------------
!! OpenMP instructions :
!! Set env variable OMP_NUM_THREADS=8 (or accordingly)
!! Set env variable OMP_STACKSIZE=2000000
!! Compile with -fopenmp (gfortran) or -Qopenmp (ifort) switch
! ---------------------------------------------------------

program plummer
    IMPLICIT NONE
    real(kind=8), parameter :: PI = 4*atan(1.)
	real(kind=8), parameter :: G = 4.498279e-3
    integer, parameter :: dim = 3, npar=10000
    real(kind=8), dimension(npar,dim) :: x,v
	real(kind=8) :: M_tot = 1e11, m
    integer :: i,j,n, nt, dsnap
    real(kind=8) :: r,t, dt
	real, dimension(dim) :: a

	! Chunk to be divided between threads
	integer,parameter :: chunk = 1000

	! Input File
	character(len=12) :: filename = 'pl0.dat'

!   Setup Initial Positions and Velocities and masses
	open(312,FILE=trim(filename),STATUS="OLD",FORM="FORMATTED",ACTION="READ")
	do j = 1,NPAR
		read(312,*) x(j,:)
		read(312,*) v(j,:)
	enddo
	close(312)
	!v = v*0.
    m = M_tot/npar

!   Simulation Parameters
    nt = 3000
    dt = 0.005
    t = 0.
	dsnap = 3

!   Time-Marching Loop
    do n = 1,nt
		!$OMP PARALLEL SHARED(x,v) PRIVATE(i,a,r)
  		!$OMP DO SCHEDULE(STATIC,CHUNK)
		do i=1,npar
		! ---------------------------------------------------------
		!				Position Verlet Algorithm
			x(i,:) = x(i,:) + 0.5 * dt * v(i,:)

		!  Acceleration due to other masses
			a = (/0.,0.,0./)
			do j=1,npar
				if (i/=j) then
					r =	 norm2(x(i,:)-x(j,:))
					a = a - (x(i,:)-x(j,:))/(r**3)
				endif
			enddo

			v(i,:) = v(i,:) + dt * G * m * a
			x(i,:) = x(i,:) + 0.5 * dt * v(i,:)
		! ---------------------------------------------------------
		enddo
		!$OMP ENDDO
		!$OMP END PARALLEL
		t = t+dt

		if (modulo(n,dsnap)==0) then
            call output(x,t)
			if(modulo(n,90)==0) then
				print*, 'Iteration: ', n
			endif
        endif
    enddo

    call output(x,t) ! Output last values

contains
!***********************************************************************
subroutine output(x,t)
    real(kind=8),dimension(npar,dim),intent(in) :: x
    real(kind=8),intent(in) :: t
    integer :: k, f_handle = 314
    character(len=12) :: f_name, num_sfx
!    do k = 1,npar
!		write(*,*) k,t,x(k,:)
!	enddo
    write(num_sfx,"(I5)") n
	f_name = 'pl'//trim(adjustl(num_sfx))//'.dat'
    open(f_handle,FILE=trim(f_name),FORM="formatted")
    do k = 1,npar
		write(f_handle,FMT=*) x(k,:)
		write(f_handle,FMT=*) v(k,:)
    enddo
	close(f_handle)
endsubroutine output
!***********************************************************************
endprogram plummer


SUBROUTINE idomats

!-------------------------------------------------------------
!
!  Integral discrete ordinates matrices
!
!   Control the construction of jmat, kmat, jpsi, kpsi
!   Matrices nned to be made only once, then idot.f90 will
!    use them to solve the system of equations
!
!-------------------------------------------------------------

USE invar
USE solvar
IMPLICIT NONE
INTEGER :: ieq, i, j, k, info, m, t, sdi, ii, jj, kk, rsx, rsy, rsz

! Initialize the matrices
jmat = 0.0d0
kmat = 0.0d0
jpsi = 0.0d0
kpsi = 0.0d0

!------------------------------------------------------------------
! Want to make all the operators for each sub-domain one at a time
sdi = 0
DO k = 1, nzsd
   rsz = (k-1)*sdnz
   DO j = 1, nysd
      rsy = (j-1)*sdny
      DO i = 1, nxsd
         sdi = sdi + 1
         rsx = (i-1)*sdnx

         ! Can now start the single sweep for constructing all matrices
         CALL matsweep(sdi,rsx,rsy,rsz)

         ! Begin constructing the RHS
         DO kk = 1, sdnz
            DO jj = 1, sdny
               DO ii = 1, sdnx
                  ieq = ii + (jj-1)*sdnx + (kk-1)*xys
                  src(ieq,sdi) = s(ii+rsx,jj+rsy,kk+rsz)/sigs(mat(ii+rsx,jj+rsy,kk+rsz))
               END DO
            END DO
         END DO

         ! Multiply the source vector by the Jacobi iteration matrix
         DO jj = 1, neq
            sv(jj,sdi) = DOT_PRODUCT(jmat(:,jj,sdi),src(:,sdi))
         END DO

         ! Form the LHS matrix
         jmat(:,:,sdi) = -jmat(:,:,sdi)
         DO t = 1, neq
            jmat(t,t,sdi) = 1.0d0 + jmat(t,t,sdi)
         END DO

!print *, sdi
!print *, jmat

         !----------------------------------------------------------------
         ! Need to factor jmat

         CALL dgetrf(neq,neq,jmat(:,:,sdi),neq,piv(:,sdi),info)
         IF (info /= 0) THEN
            WRITE (8,'(//,1X,A)') "ERROR: jmat either has illegal value or is singular, cannot factor."
            STOP
         END IF

         ! Have needed values: src, sv, jmat, kmat, jpsi, kpsi, piv

      END DO        ! x sub-domain divisions
   END DO           ! y sub-domain divisions
END DO              ! z sub-domain divisions

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

RETURN
END SUBROUTINE idomats


module geom_distances
  use, intrinsic :: iso_fortran_env, only : stdin=>input_unit, &
       stdout=>output_unit, &
       stderr=>error_unit
  use geom_utils
  use geom_types
  implicit none
  private
  public :: LineBoxDistanceSquared, LineSegmentBoxDistanceSquared, PointBoxDistanceSquared, CapsuleBoxDistanceSquared
  public :: PointLineDistanceSquared, PointLineSegDistanceSquared

contains
  subroutine CapsuleBoxDistanceSquared(box, capsule, d2)
    type(Box_t), intent(in) :: box
    type(Capsule_t), intent(in) :: capsule
    real(dp), intent(out) :: d2

    call LineSegmentBoxDistanceSquared(box, capsule%segment, d2)

    ! Get min distance - capsule's sphere radius
    d2 = max(d2-capsule%r**2, 0._dp)

  end subroutine CapsuleBoxDistanceSquared

  subroutine LineSegmentBoxDistanceSquared(box, seg, d2)
    type(Box_t), intent(in) :: box
    type(Segment_t), intent(in) :: seg
    real(dp), intent(out) :: d2

    real(dp) :: t
    type(Line_t) :: line

    line%origin = seg%start
    line%direction = seg%end - seg%start

    call LineBoxDistanceSquared(box, line, d2, t)

    if (t < 0) then
       call PointBoxDistanceSquared(box, seg%start, d2)
    else if (t > 1) then
       call PointBoxDistanceSquared(box, seg%end, d2)
    end if
  end subroutine LineSegmentBoxDistanceSquared

  subroutine LineBoxDistanceSquared(box, line, d2, t)
    type(Box_t), intent(in) :: box
    type(Line_t), intent(in) :: line
    real(dp), intent(out) :: d2, t

    real(dp) :: Pprime(3), tmp(3), dprime(3)
    integer :: n0, axis
    logical :: ind(3)

    type(Box_t) :: newBox
    type(Line_t) :: newLine

    ! Project segment onto box own frame
    tmp = (line%origin - box%origin)
    Pprime = (/ &
         dot_product(tmp, box%u), &
         dot_product(tmp, box%v), &
         dot_product(tmp, box%w)  &
         /)
    dprime = (/ &
         dot_product(line%direction, box%u), &
         dot_product(line%direction, box%v), &
         dot_product(line%direction, box%w)  &
         /)

    if (dprime(1) < 0) then
       Pprime(1) = -Pprime(1)
       dprime(1) = -dprime(1)
    end if
    if (dprime(2) < 0) then
       Pprime(2) = -Pprime(2)
       dprime(2) = -dprime(2)
    end if
    if (dprime(3) < 0) then
       Pprime(3) = -Pprime(3)
       dprime(3) = -dprime(3)
    end if

    ! Store new Box and line
    newBox = box
    newBox%u = (/1, 0, 0/)
    newBox%v = (/0, 1, 0/)
    newBox%w = (/0, 0, 1/)

    newLine = line
    newLine%origin = Pprime
    newLine%direction = dprime

    ! Count number of null component
    ind = dprime > 0._dp
    n0 = count(.not. ind)
    if (n0 == 3) then
       call PointBoxDistanceSquared(newBox, newLine%origin, d2)
       t = 0
    else if (n0 == 2) then
       ! Select non null axis
       if (ind(1)) axis = 1
       if (ind(2)) axis = 2
       if (ind(3)) axis = 3
       call CaseTwoZeroComponents(newLine, newBox, axis, d2, t)
    else if (n0 == 1) then
       ! Select non null axis
       if (.not. ind(1)) axis = 1
       if (.not. ind(2)) axis = 2
       if (.not. ind(3)) axis = 3
       call CaseOneZeroComponents(newLine, newBox, axis, d2, t)
    else if (n0 == 0) then
       call CaseNoZeroComponents(newLine, newBox, d2, t)
    end if

  contains
    subroutine CaseTwoZeroComponents(line, box, X, d2, t)
      type(Box_t), intent(in) :: box
      type(Line_t), intent(in) :: line
      integer, intent(in) :: X

      real(dp), intent(out) :: d2, t

      real(dp) :: delta
      integer :: Y, Z

      ! In the comments, we assume axis to be x-axis
      ! Maps 2->3, 3->1 and 1->2
      Y = next_axis(X)
      Z = next_axis(Y)

      d2 = 0

      t = (box%extents(X) - line%origin(X)) / line%direction(X)
      ! Distance in y direction
      if (line%origin(Y) < -box%extents(Y)) then
         delta = line%origin(Y) + box%extents(Y)
         d2 = d2 + delta**2
      else if (line%origin(Y) > box%extents(Y)) then
         delta = line%origin(Y) - box%extents(Y)
         d2 = d2 + delta**2
      end if

      ! Distance in z direction
      if (line%origin(Z) < -box%extents(Z)) then
         delta = line%origin(Z) + box%extents(Z)
         d2 = d2 + delta**2
      else if (line%origin(Z) > box%extents(Z)) then
         delta = line%origin(Z) - box%extents(Z)
         d2 = d2 + delta**2
      end if

    end subroutine CaseTwoZeroComponents

    subroutine CaseOneZeroComponents(line, box, Z, d2, t)
      type(Box_t), intent(in) :: box
      type(Line_t), intent(in) :: line
      integer, intent(in) :: Z

      real(dp), intent(out) :: d2, t

      real(dp) :: prod0, prod1, ptMinusExtents(3), tmp, delta, invLSquared, inv
      integer :: X, Y

      d2 = 0

      ! In the comments, we assume axis to be the z axis
      ! Get next axis in order
      X = next_axis(Z)
      Y = next_axis(Y)

      ptMinusExtents = line%origin - box%extents

      prod0 = line%direction(Y) * ptMinusExtents(X)
      prod1 = line%direction(X) * ptMinusExtents(Y)

      if (prod0 >= prod1) then
         ! Line intersects x-axis of box
         ! Closest point is along bottom edge of right face of box
         tmp = line%origin(Y) + box%extents(Y)
         delta = prod0 - line%direction(X) * tmp

         if (delta >= 0) then
            ! No intersection, so compute distance
            invLSquared = 1._dp / (&
                 line%direction(X) * line%direction(X) + &
                 line%direction(Y) * line%direction(Y))
            d2 = d2 + delta*delta * invLSquared
            t = - (line%direction(X) * ptMinusExtents(X) + line%direction(Y) * tmp) * invLSquared
         else
            ! Line intersects box, distance is 0
            ! d2 = d2 + 0
            inv = 1 / line%direction(X)
            t = -ptMinusExtents(X) * inv
         end if
      else
         ! Line intersects y-axis of box
         ! Closest point is along top edge of left face of box
         tmp = line%origin(X) + box%extents(X)
         delta = prod1 - line%direction(Y) * tmp

         if (delta >= 0) then
            ! No intersection, so compute distance
            invLSquared = 1._dp / (&
                 line%direction(X) * line%direction(X) + &
                 line%direction(Y) * line%direction(Y))
            d2 = d2 + delta*delta * invLSquared
            t = - (line%direction(Y) * ptMinusExtents(Y) + line%direction(X) * tmp) * invLSquared
         else
            ! Line intersects box, distance is 0
            inv = 1 / line%direction(Y)
            t = -ptMinusExtents(Y) * inv
         end if
      end if

      ! Now consider the z-direction
      if (line%origin(Z) < -box%extents(Z)) then
         delta = line%origin(Z) + box%extents(Z)
         d2 = d2 + delta*delta
      else if (line%origin(Z) > box%extents(Z)) then
         delta = line%origin(Z) - box%extents(Z)
         d2 = d2 + delta*delta
      end if

    end subroutine CaseOneZeroComponents

    subroutine CaseNoZeroComponents(line, box, d2, t)
      type(Box_t), intent(in) :: box
      type(Line_t), intent(in) :: line

      real(dp), intent(out) :: d2, t

      real(dp) :: ptMinusExtents(3), dyEx, dxEy, dzEx, dxEz, dzEy, dyEz
      integer :: X=1, Y=2, Z=3

      ptMinusExtents = line%origin - box%extents
      dyEx = line%direction(Y) * ptMinusExtents(X)
      dxEy = line%direction(X) * ptMinusExtents(Y)

      if (dyEx >= dxEy) then
         dzEx = line%direction(Z) * ptMinusExtents(X)
         dxEz = line%direction(X) * ptMinusExtents(Z)

         if (dzEx>= dxEz) then
            ! Line intersects x = box.extent.x plane
            call Face(line, box, ptMinusExtents, X, d2, t)
         else
            ! Line intersects z = box.extent.z plane
            call Face(line, box, ptMinusExtents, Z, d2, t)
         end if
      else
         dzEy = line%direction(Z) * ptMinusExtents(Y)
         dyEz = line%direction(Y) * ptMinusExtents(Z)

         if (dzEy >= dyEz) then
            ! Line intersects y = box.extent.y plane
            call Face(line, box, ptMinusExtents, Y, d2, t)
         else
            ! Line intersects z = box.extent.z plane
            call Face(line, box, ptMinusExtents, Z, d2, t)
         end if
      end if

    end subroutine CaseNoZeroComponents

    subroutine Face(line, box, ptMinusExtents, axis, d2, t)
      type(Box_t), intent(in) :: box
      type(Line_t), intent(in) :: line
      real(dp), intent(in) :: ptMinusExtents(3)
      integer, intent(in) :: axis

      real(dp), intent(out) :: d2, t

      real(dp) :: ptPlusExtents(3), lSqr, tmp, delta, inverse
      integer :: X, Y, Z

      X = axis
      Y = next_axis(X)
      Z = next_axis(Y)

      ptPlusExtents = line%origin + box%extents

      d2 = 0

      if (line%direction(X) * ptPlusExtents(Y) >= line%direction(Y) * ptMinusExtents(X)) then
         ! Region 0, 5 or 4
         if (line%direction(X) * ptPlusExtents(Z) >= line%direction(Z) * ptMinusExtents(X)) then
            ! Region 0 - line intersects face
            ! Distance is 0
            inverse = 1.0_dp / line%direction(X)
            t = -ptMinusExtents(X) * inverse
         else
            ! Region 4 or 5
            lSqr = line%direction(X)**2 + line%direction(Z)**2
            tmp = lSqr * ptPlusExtents(Y) - line%direction(Y) * &
                 (line%direction(X) * ptMinusExtents(X) + line%direction(Z) * ptPlusExtents(Z))

            if (tmp <= 2 * lSqr * box%extents(Y)) then
               ! Region 4
               call region4code(line, ptMinusExtents, ptPlusExtents, X, Y, Z,&
                    tmp, lSqr, delta, t, d2)
            else
               ! Region 5
               call region5code(line, ptMinusExtents, ptPlusExtents, X, Y, Z,&
                    lSqr, delta, t, d2)
            end if
         end if
      else
         if (line%direction(X) * ptPlusExtents(Z) >= line%direction(Z) * ptMinusExtents(X)) then
            ! Region 1 or 2
            lSqr = line%direction(X)**2 + line%direction(Y)**2
            tmp = lSqr * ptPlusExtents(Z) - line%direction(Z) * &
                 (line%direction(X) * ptMinusExtents(X) + line%direction(Y) * ptPlusExtents(Y))
            if (tmp <= 2 * lSqr * box%extents(Z)) then
               ! Region 2
               call region2code(line, ptMinusExtents, ptPlusExtents, X, Y, Z,&
                    tmp, lSqr, delta, t, d2)
            else
               ! Region 1
               call region1code(line, ptMinusExtents, ptPlusExtents, X, Y, Z,&
                    lSqr, delta, t, d2)
            end if
         else
            lSqr = line%direction(X)**2 &
                 + line%direction(Z)**2
            tmp = lSqr * ptPlusExtents(Y) - line%direction(Y) * &
                 (line%direction(X) * ptMinusExtents(X) + line%direction(Z) * ptPlusExtents(Z))

            if (tmp >= 0) then
               ! Region 4 or 5
               if (tmp <= 2 * lSqr * box%extents(Y)) then
                  ! Region 4. Same as before (TODO)
                  call region4code(line, ptMinusExtents, ptPlusExtents, X, Y, Z,&
                    tmp, lSqr, delta, t, d2)
               else
                  ! Region 5. Same as before (TODO)
                  call region5code(line, ptMinusExtents, ptPlusExtents, X, Y, Z,&
                    lSqr, delta, t, d2)
               end if
            end if

            lSqr = line%direction(X)**2 + line%direction(Y)**2
            tmp = lSqr * ptPlusExtents(Z) - line%direction(Z) * &
                 (line%direction(X) * ptMinusExtents(X) + line%direction(Y) * ptPlusExtents(Y))

            if (tmp >= 0) then
               ! Region 1 or 2
               if (tmp <= 2 * lSqr * box%extents(Z)) then
                  ! Region 2. Same as before
                  call region2code(line, ptMinusExtents, ptPlusExtents, X, Y, Z,&
                    tmp, lSqr, delta, t, d2)
               else
                  ! Region 1. Same as before
                  call region1code(line, ptMinusExtents, ptPlusExtents, X, Y, Z,&
                       lSqr, delta, t, d2)
               end if
               return ! d2
            end if

            ! Region 3
            lSqr = lSqr + line%direction(Y)**2
            delta = line%direction(X) * ptMinusExtents(X) &
                 + line%direction(Y) * ptPlusExtents(Y) &
                 + line%direction(Z) * ptPlusExtents(Z)
            t = - delta / lSqr
            d2 = d2 + ptMinusExtents(X)**2 &
                 + ptPlusExtents(Y)**2 &
                 + ptPlusExtents(Z)**2 &
                 + delta * t
         end if
      end if
    end subroutine Face

    subroutine region1code(line, ptMinusExtents, ptPlusExtents, X, Y, Z,&
         lSqr, delta, t, d2)
      type(Line_t), intent(in) :: line
      real(dp), intent(in) :: ptMinusExtents(3), ptPlusExtents(3)
      integer, intent(in) :: X, Y, Z

      real(dp), intent(inout) :: lSqr, delta, t, d2

      lSqr = lSqr + line%direction(Z)**2
      delta = line%direction(X) * ptMinusExtents(X) &
           + line%direction(Y) * ptMinusExtents(Y) &
           + line%direction(Z) * ptPlusExtents(Z)

      t = -delta / lSqr
      d2 = d2 + ptMinusExtents(X)**2 &
           + ptPlusExtents(Y)**2 &
           + ptMinusExtents(Z)**2 &
           + delta * t

    end subroutine region1code

    subroutine region2code(line, ptMinusExtents, ptPlusExtents, X, Y, Z, &
         tmp, lSqr, delta, t, d2)
      type(Line_t), intent(in) :: line
      real(dp), intent(in) :: ptMinusExtents(3), ptPlusExtents(3)
      integer, intent(in) :: X, Y, Z

      real(dp), intent(inout) :: tmp, lSqr, delta, t, d2

      tmp = ptPlusExtents(Z) - tmp / lSqr
      lSqr = lSqr + line%direction(Z)**2
      delta = line%direction(X) * ptMinusExtents(X) &
           + line%direction(Y) * ptPlusExtents(Y) &
           + line%direction(Z) * tmp
      t = -delta/ lSqr
      d2 = d2 + ptMinusExtents(X)**2 &
           + ptMinusExtents(Y)**2 &
           + tmp**2 &
           + delta * t
    end subroutine region2code

    subroutine region4code(line, ptMinusExtents, ptPlusExtents, X, Y, Z, &
         tmp, lSqr, delta, t, d2)
      type(Line_t), intent(in) :: line
      real(dp), intent(in) :: ptMinusExtents(3), ptPlusExtents(3)
      integer, intent(in) :: X, Y, Z

      real(dp), intent(inout) :: tmp, lSqr, delta, t, d2

      tmp = ptPlusExtents(Y) - tmp / lSqr
      lSqr = lSqr + line%direction(Y)**2
      delta = line%direction(X) * ptMinusExtents(X) &
           + line%direction(Y) * tmp &
           + line%direction(Z) * ptPlusExtents(Z)
      t = -delta / lSqr
      d2 = d2 + ptMinusExtents(X)**2 + tmp**2 + ptPlusExtents(Z)**2 + delta * t
    end subroutine region4code

    subroutine region5code(line, ptMinusExtents, ptPlusExtents, X, Y, Z, &
         lSqr, delta, t, d2)
      type(Line_t), intent(in) :: line
      real(dp), intent(in) :: ptMinusExtents(3), ptPlusExtents(3)
      integer, intent(in) :: X, Y, Z

      real(dp), intent(inout) :: lSqr, delta, t, d2

      lSqr = lSqr + line%direction(Y)**2
      delta = line%direction(X) * ptMinusExtents(X) &
           + line%direction(Y) * ptMinusExtents(Y) &
           + line%direction(Z) * ptPlusExtents(Z)
      t = - delta/ lSqr

      d2 = d2 + ptMinusExtents(X)**2 &
           + ptMinusExtents(Y) **2 &
           + ptPlusExtents(Z)**2 &
           + delta * t

    end subroutine region5code

  end subroutine LineBoxDistanceSquared

  subroutine PointBoxDistanceSquared(box, point, d2)
    type(Box_t), intent(in) :: box
    real(dp), intent(in) :: point(3)
    real(dp), intent(out) :: d2

    real(dp) :: offset(3), pPrime(3), d

    integer :: dim

    d2 = 0
    offset = point - box%origin
    pPrime = (/&
         dot_product(offset, box%u), &
         dot_product(offset, box%v), &
         dot_product(offset, box%w)  &
         /)

    do dim = 1, 3
       if (pPrime(dim) < -box%extents(dim)) then
          d = pPrime(dim) + box%extents(dim)
          d2 = d2 + d**2
       else if (pPrime(dim) > box%extents(dim)) then
          d = pPrime(dim) - box%extents(dim)
          d2 = d2 + d**2
       else
          ! nothing to do
       end if
    end do

  end subroutine PointBoxDistanceSquared

  subroutine PointLineDistanceSquared(line, point, t, d2)
    type(Line_t), intent(in) :: line
    real(dp), intent(in), dimension(3) :: point

    real(dp), intent(out) :: d2, t

    real(dp) :: qPrime(3), vec(3)

    t = dot_product(line%direction, point - line%origin) / dot_product(line%direction, line%direction)
    qPrime = line%origin + t * line%direction
    vec = point - qPrime
    d2 = dot_product(vec, vec)
  end subroutine PointLineDistanceSquared

  subroutine PointLineSegDistanceSquared(segment, point, t, d2)
    type(Segment_t), intent(in) :: segment
    real(dp), intent(in), dimension(3) :: point

    real(dp), intent(out) :: d2, t

    type(Line_t) :: line
    real(dp) :: vec(3)

    line%origin = segment%start
    line%direction = segment%end - segment%start

    call PointLineDistanceSquared(line, point, t, d2)
    if (t < 0) then
       t = 0
       vec = point - segment%start
       d2 = dot_product(vec, vec)
    else if (t > 1) then
       t = 1
       vec = point - segment%end
       d2 = dot_product(vec, vec)
    end if

  end subroutine PointLineSegDistanceSquared

end module geom_distances


! MIT License
!
! Copyright (c) 2020 SHEMAT-Suite
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the "Software"), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in all
! copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
! SOFTWARE.

!>    @brief normalise the linear system, matrix and the right side
!>    @param[in] N size of all given vectors
!>    @param[in] mbc_mask boundary mask
!>    @param[in,out] mw right side, solution
!>    @param[in] mx [x]-vector
!>    @param[in,out] MA 1. diagonal of the system matrix
!>    @param[in,out] MB 2. diagonal of the system matrix
!>    @param[in,out] MC 3. diagonal of the system matrix
!>    @param[in,out] MD 4. diagonal of the system matrix
!>    @param[in,out] ME 5. diagonal of the system matrix
!>    @param[in,out] MF 6. diagonal of the system matrix
!>    @param[in,out] MG 7. diagonal of the system matrix
!>    @param[in,out] dnormalise normalising vector for adaptive resiuum (disabled function - working on matnormalise), as input initialised with second offset (dominant) diagonal*x
!>    @param[out] matnormalise normalising vector for matrix system
      SUBROUTINE norm_linsys2(n,mbc_mask,mw,mx,ma,mb,mc,md,me,mf,mg,dnormalise,matnormalise)
        IMPLICIT NONE
        INTEGER n, i
!     normalising value
        DOUBLE PRECISION dnormalise(n), matnormalise(n)
!     matrix coefficients
        DOUBLE PRECISION ma(n), mb(n), mc(n), md(n), me(n), mf(n), &
          mg(n)
!     right side, solution
        DOUBLE PRECISION mw(n), mx(n)
        CHARACTER mbc_mask(n)

!     get the norm.-vector for the normalisation of the system (in "matnormalise")
        CALL get_norm2(n,mw,mbc_mask,md,mx,matnormalise,dnormalise)

!     normalise the system matrix
        DO i = 1, n
          ma(i) = ma(i)*matnormalise(i)
        END DO
        DO i = 1, n
          mb(i) = mb(i)*matnormalise(i)
        END DO
        DO i = 1, n
          mc(i) = mc(i)*matnormalise(i)
        END DO
        DO i = 1, n
          md(i) = md(i)*matnormalise(i)
        END DO
        DO i = 1, n
          me(i) = me(i)*matnormalise(i)
        END DO
        DO i = 1, n
          mf(i) = mf(i)*matnormalise(i)
        END DO
        DO i = 1, n
          mg(i) = mg(i)*matnormalise(i)
        END DO
!     normalise the right side
        DO i = 1, n
          mw(i) = mw(i)*matnormalise(i)
        END DO

!     disable the adaptive normalisation (normalisation vector = 0)
        CALL set_dval(n,0.0d0,dnormalise)

        RETURN
      END


module mbpt2_mod
use types, only: dp
use scf, only: ijkl2intindex
implicit none

contains

real(dp) function term1(moint2, lam, Noccupied) result(E2)
real(dp), intent(in) :: moint2(:), lam(:)
integer, intent(in) :: Noccupied
integer :: a, b, r, s
E2 = 0
do a = 1, Noccupied
    do b = 1, Noccupied
        do r = Noccupied+1, size(lam)
            do s = Noccupied+1, size(lam)
                E2 = E2 + (  &
                        + (-1)**(2+2) * 2**2 / 2._dp  &
                      * moint2(ijkl2intindex(a, r, b, s))  &
                      * moint2(ijkl2intindex(r, a, s, b))  &
                        + (-1)**(1+2) * 2**1 / 2._dp  &
                      * moint2(ijkl2intindex(a, r, b, s))  &
                      * moint2(ijkl2intindex(s, a, r, b))  &
                    ) / (  &
                    (-lam(r)-lam(s)+lam(a)+lam(b))  &
                    )
            end do
        end do
    end do
end do
end function

end module


!-------------------------------------------------------------------------------
! Copyright (c) 2019 FrontISTR Commons
! This software is released under the MIT License, see LICENSE.txt
!-------------------------------------------------------------------------------
!> \brief  This module provides function on NEO-HOOKEAN hyperelastic material
!> \par neo-Hookean hyperelastic material
!>  - potential function : \f$ \Psi = \frac{\mu}{2} ( I_{c}-3 ) - \mu \ln J + \frac{\lambda}{2} ( \ln J )^2 \f$
!>  - 2nd Piola-Kirchhoff stress : \f$ \mathbf{S} = \mu ( \mathbf{I} - \mathbf{C}^{-1} ) + \lambda ( \ln J ) \mathbf{C}^{-1} \f$
!>  - elastic tangent coefficient : \f$ \mathbf{\mathsf{C}} = \lambda \mathbf{C}^{-1} \otimes \mathbf{C}^{-1} + 2 ( \mu - \lambda \ln J ) \mathbf{I} \f$
module m_ElasticNeoHooke
  use mMaterial
  implicit none
  integer, parameter, private :: kreal = kind(0.0d0)
  contains

!-------------------------------------------------------------------------------
!> \brief This subroutine provides elastic tangent coefficient for neo-Hookean material
!-------------------------------------------------------------------------------
  subroutine calElasticNeoHooke( matl, sectType, cijkl, ftn )
!
    type( tMaterial ), intent(in) :: matl            !> material properties
    integer, intent(in)           :: sectType        !> not used currently
    real(kind=kreal), intent(out) :: cijkl(3,3,3,3)  !> \f$ \mathbf{\mathsf{C}} \f$ Elastic tanget coefficient
    real(kind=kreal), INTENT(IN)  :: ftn(:,:)        !> \f$ \mathbf{F}_{n+1}^{(k)} \f$ deformation gradient tensor ( \f$ \mathbf{F} = \mathbf{I} + \mathbf{u}_{n+1}^{(k)} \otimes \mathbf{\nabla}_{X} \f$ )
!
    integer :: i, j, k, l
    real(kind=kreal) :: ctn(3,3)     !< right Cauchy-Green deformation tensor
    real(kind=kreal) :: ctninv(3,3)  !< inversion of right Cauchy-Green deformation tensor
    real(kind=kreal) :: det, dum
    real(kind=kreal) :: cc(3,3,3,3), ii(3,3,3,3), delta(3,3)
    real(kind=kreal) :: ee, pp, lambda, mu
    real(kind=kreal) :: lnJ
!
! ----- Lame coefficients
    ee = matl%variables(M_YOUNGS)
    pp = matl%variables(M_POISSON)
    lambda = pp*ee/(1.d0+pp)/(1.d0-2.d0*pp)
    mu     = ee/2.d0/(1.d0+pp)
!
! ----- calculate the right Cauchy-Green deformation tensor C
    ctn(:,:)    = 0.d0
    do i=1,3
      do j=1,3
        do k=1,3
          ctn(i,j) = ctn(i,j) + ftn(k,i)*ftn(k,j)
        enddo
      enddo
    enddo
!
! ---- inverse of right Cauchy-Green deformation tensor
!    --- determinant of Jacobian
    det=ctn(1,1)*ctn(2,2)*ctn(3,3)                                             &
       +ctn(2,1)*ctn(3,2)*ctn(1,3)                                             &
       +ctn(3,1)*ctn(1,2)*ctn(2,3)                                             &
       -ctn(3,1)*ctn(2,2)*ctn(1,3)                                             &
       -ctn(2,1)*ctn(1,2)*ctn(3,3)                                             &
       -ctn(1,1)*ctn(3,2)*ctn(2,3)
    if( det==0.d0 ) stop "Math error in ctn(right CG deformation tensor) Determinaut==0.0"
! ----- calculate the \ln J
    lnJ = 0.5d0*log(det)
!
!    --- inversion of Jacobian
    ctninv(:,:) = 0.d0
    dum=1.d0/det
    ctninv(1,1)=dum*( ctn(2,2)*ctn(3,3)-ctn(3,2)*ctn(2,3) )
    ctninv(1,2)=dum*(-ctn(1,2)*ctn(3,3)+ctn(3,2)*ctn(1,3) )
    ctninv(1,3)=dum*( ctn(1,2)*ctn(2,3)-ctn(2,2)*ctn(1,3) )
    ctninv(2,1)=dum*(-ctn(2,1)*ctn(3,3)+ctn(3,1)*ctn(2,3) )
    ctninv(2,2)=dum*( ctn(1,1)*ctn(3,3)-ctn(3,1)*ctn(1,3) )
    ctninv(2,3)=dum*(-ctn(1,1)*ctn(2,3)+ctn(2,1)*ctn(1,3) )
    ctninv(3,1)=dum*( ctn(2,1)*ctn(3,2)-ctn(3,1)*ctn(2,2) )
    ctninv(3,2)=dum*(-ctn(1,1)*ctn(3,2)+ctn(3,1)*ctn(1,2) )
    ctninv(3,3)=dum*( ctn(1,1)*ctn(2,2)-ctn(2,1)*ctn(1,2) )
!
! ----- calculation the \bm{C}^{-1} \otimes \bm{C}^{-1}
    cc(:,:,:,:) = 0.d0
    do i=1,3
      do j=1,3
        do k=1,3
          do l=1,3
            cc(i,j,k,l) = cc(i,j,k,l) + ctninv(i,j)*ctninv(k,l)
          enddo
        enddo
      enddo
    enddo
!
! ----- calculation the \bm{\mathsf{I}}
    ii(:,:,:,:) = 0.d0
    do i=1,3
      do j=1,3
        do k=1,3
          do l=1,3
            ii(i,j,k,l) = 0.5d0*( ctninv(i,k)*ctninv(j,l)         &
                                 + ctninv(i,l)*ctninv(j,k) )
          enddo
        enddo
      enddo
    enddo
!
! ----- elastic tanget coefficients for neo-Hooke hyperelastic model
!    \bm{\mathsf{C}} = \lambda \bm{C}^{-1} \otimes \bm{C}^{-1} + 2 ( \mu - \lambda \ln J ) \bm{\mathsf{I}}
    cijkl(:,:,:,:) = 0.d0
    do i=1,3
      do j=1,3
        do k=1,3
          do l=1,3
            cijkl(i,j,k,l) = lambda*cc(i,j,k,l) + 2.d0*(mu-lambda*lnJ)*ii(i,j,k,l)
          enddo
        enddo
      enddo
    enddo
!
  end subroutine calElasticNeoHooke
!
!
!
!-------------------------------------------------------------------------------
!> \brief This subroutine provides to update stress and strain for neo-Hookean material
!-------------------------------------------------------------------------------
  subroutine calUpdateElasticNeoHooke( matl, sectType, dstrain, dstress, ftn )
    type( tMaterial ), intent(in) :: matl           !> material properties
    integer, intent(in)           :: sectType       !> not used currently
    real(kind=kreal), intent(out) :: dstrain(6)     !> \f$ \mathbf{E} \f$ Cauchy-Green strain
    real(kind=kreal), intent(out) :: dstress(6)     !> \f$ \mathbf{S} \f$ 2nd Piola-Kirchhoff stress
    real(kind=kreal), intent(in)  :: ftn(:,:)       !> \f$ \mathbf{F}_{n+1}^{(k)} \f$ deformation gradient tensor ( \f$ \mathbf{F} = \mathbf{I} + \mathbf{u}_{n+1}^{(k)} \otimes \mathbf{\nabla}_{X} \f$ )
!
    integer :: i, j, k
    real(kind=kreal) :: ctn(3,3), itn(3,3)
    real(kind=kreal) :: ctninv(3,3)
    real(kind=kreal) :: det, dum
    real(kind=kreal) :: ee, pp, lambda, mu
    real(kind=kreal) :: lnJ
    real(kind=kreal) :: CGstrain(3,3), PKstress(3,3)
!
    real(kind=kreal) :: volJ
    real(kind=kreal) :: sf(3,3), cauchy(3,3), mises
!
! ----- Lame coefficients
    ee = matl%variables(M_YOUNGS)
    pp = matl%variables(M_POISSON)
    lambda = pp*ee/(1.d0+pp)/(1.d0-2.d0*pp)
    mu     = ee/2.d0/(1.d0+pp)
!
! ----- calculate the right Cauchy-Green deformation tensor C
    ctn(:,:)    = 0.d0
    do i=1,3
      do j=1,3
        do k=1,3
          ctn(i,j) = ctn(i,j) + ftn(k,i)*ftn(k,j)
        enddo
      enddo
    enddo
!
! ----- calculate the right Cauchy-Green deformation tensor C
    itn(:,:)   = 0.d0
    do i=1,3
      itn(i,i) = 1.d0
    enddo
!
! ---- inverse of right Cauchy-Green deformation tensor
!    --- determinant of Jacobian
    det=ctn(1,1)*ctn(2,2)*ctn(3,3)                                             &
       +ctn(2,1)*ctn(3,2)*ctn(1,3)                                             &
       +ctn(3,1)*ctn(1,2)*ctn(2,3)                                             &
       -ctn(3,1)*ctn(2,2)*ctn(1,3)                                             &
       -ctn(2,1)*ctn(1,2)*ctn(3,3)                                             &
       -ctn(1,1)*ctn(3,2)*ctn(2,3)
    if( det==0.d0 ) stop "Math error in ctn(right CG deformation tensor) Determinaut==0.0"
!    --- inversion of Jacobian
    ctninv(:,:)   = 0.d0
    dum=1.d0/det
    ctninv(1,1)=dum*( ctn(2,2)*ctn(3,3)-ctn(3,2)*ctn(2,3) )
    ctninv(1,2)=dum*(-ctn(1,2)*ctn(3,3)+ctn(3,2)*ctn(1,3) )
    ctninv(1,3)=dum*( ctn(1,2)*ctn(2,3)-ctn(2,2)*ctn(1,3) )
    ctninv(2,1)=dum*(-ctn(2,1)*ctn(3,3)+ctn(3,1)*ctn(2,3) )
    ctninv(2,2)=dum*( ctn(1,1)*ctn(3,3)-ctn(3,1)*ctn(1,3) )
    ctninv(2,3)=dum*(-ctn(1,1)*ctn(2,3)+ctn(2,1)*ctn(1,3) )
    ctninv(3,1)=dum*( ctn(2,1)*ctn(3,2)-ctn(3,1)*ctn(2,2) )
    ctninv(3,2)=dum*(-ctn(1,1)*ctn(3,2)+ctn(3,1)*ctn(1,2) )
    ctninv(3,3)=dum*( ctn(1,1)*ctn(2,2)-ctn(2,1)*ctn(1,2) )
!
! ----- calculate the \ln J
    lnJ = 0.5d0*log(det)
!
! ----- calculate the strain
    CGstrain(:,:) = 0.d0
    CGstrain(1:3,1:3) = 0.5d0*( ctn(1:3,1:3) - itn(1:3,1:3) )
!
! ----- calculate the stress
    PKstress(:,:) = 0.d0
    PKstress(1:3,1:3) = mu*( itn(1:3,1:3) - ctninv(1:3,1:3) ) + lambda*lnJ*ctninv(1:3,1:3)
!
    dstrain(:)    = 0.d0
    dstress(:)    = 0.d0
!
    dstrain(1) = CGstrain(1,1)
    dstrain(2) = CGstrain(2,2)
    dstrain(3) = CGstrain(3,3)
    dstrain(4) = 0.5d0*( CGstrain(1,2) + CGstrain(2,1) )
    dstrain(5) = 0.5d0*( CGstrain(2,3) + CGstrain(3,2) )
    dstrain(6) = 0.5d0*( CGstrain(1,3) + CGstrain(3,1) )
!
    dstress(1) = PKstress(1,1)
    dstress(2) = PKstress(2,2)
    dstress(3) = PKstress(3,3)
    dstress(4) = 0.5d0*( PKstress(1,2) + PKstress(2,1) )
    dstress(5) = 0.5d0*( PKstress(2,3) + PKstress(3,2) )
    dstress(6) = 0.5d0*( PKstress(1,3) + PKstress(3,1) )

  end subroutine

end module m_ElasticNeoHooke


PROGRAM F009

    ! Copyright 2021 Melwyn Francis Carlo

    IMPLICIT NONE

    INTEGER :: A, PRODUCT_VAL
    REAL (KIND=8) :: B, C

    A = 1
    DO
        B = (5E+5 - (1E+3 * A)) / (1E+3 - A)
        IF ( ((B - INT(B)) <= 0) .AND. (B > A) ) THEN
            C = 1000.0 - REAL(A, 8) - B
            IF (B < C) THEN
                PRODUCT_VAL = INT(REAL(A, 8) * B * C)
                EXIT
            END IF
        END IF
        A = A + 1
        IF (A == 1000) THEN
            A = A + 1
        END IF
    END DO

    PRINT ('(I0)'), PRODUCT_VAL

END PROGRAM F009


! Calculate 3-D Fourier transform of a scalar field using distributed
! memory (MPI) version of FFTW. This routine requires that the Box
! distribution of the input MultiFab already conforms to that required
! by FFTW, i.e., striped along last (z) dimension.

subroutine fft_3d(mf_fft_in, lo, hi, domain_size, dx, comm, alloc_local, mf_fft_out_real, mf_fft_out_imag, threads_ok)
    use, intrinsic :: iso_c_binding
    use fftw3_mpi
    use omp_lib

    implicit none

    integer(c_int), intent(in ) :: lo(3), hi(3), domain_size(3), comm
    integer(c_intptr_t), intent(in) :: alloc_local
    real(c_double), intent(in) :: mf_fft_in (lo(1):hi(1), lo(2):hi(2), lo(3):hi(3), 1)
    real(c_double), intent(in) :: dx
    integer, intent(in) :: threads_ok

    real(c_double), intent(out) :: mf_fft_out_real(lo(1):hi(1), lo(2):hi(2), lo(3):hi(3), 1)
    real(c_double), intent(out) :: mf_fft_out_imag(lo(1):hi(1), lo(2):hi(2), lo(3):hi(3), 1)

    integer(c_intptr_t) :: l, m, n, local_n
    type(c_ptr) :: plan, cdata
    complex(c_double_complex), pointer :: mf_data(:, :, :)

    integer :: cmplx_i, cmplx_j, cmplx_k
    integer :: i, j, k
    real(c_double) :: dx3

    dx3 = dx*dx*dx

    l = domain_size(1)
    m = domain_size(2)
    n = domain_size(3)

    local_n = hi(3)-lo(3)+1

    ! We must use these special C-style pointers to feed data into FFTW.
    cdata = fftw_alloc_complex(alloc_local)
    call c_f_pointer(cdata, mf_data, [l, m, local_n])

    if (threads_ok /= 0) call fftw_plan_with_nthreads(omp_get_num_threads())
    plan = fftw_mpi_plan_dft_3d (n, m, l, mf_data, mf_data, comm, FFTW_BACKWARD, FFTW_MEASURE)

    ! First translate the real MultiFab data to a complex array. The
    ! indices for the local complex data arrays start their indices at
    ! one, unlike the Box indices which follow the domain grid
    ! coordinates.
    do k = lo(3), hi(3)
      cmplx_k = k - lo(3) + 1
      do j = lo(2), hi(2)
        cmplx_j = j - lo(2) + 1
        do i = lo(1), hi(1)
          cmplx_i = i - lo(1) + 1
          ! Input data to the DFT is real data so the imaginary
          ! component is zero.
          mf_data(cmplx_i, cmplx_j, cmplx_k) = cmplx(mf_fft_in(i, j, k, 1), 0.0, c_double_complex)
        end do
      end do
    end do

    call fftw_mpi_execute_dft(plan, mf_data, mf_data)

    ! Copy data back to separate MultiFabs for real and imaginary components.
    do k = lo(3), hi(3)
      cmplx_k = k - lo(3) + 1
      do j = lo(2), hi(2)
        cmplx_j = j - lo(2) + 1
        do i = lo(1), hi(1)
          cmplx_i = i - lo(1) + 1
          ! Strip out real and imaginary components and save as separate
          ! MultiFabs. This syntax is weird due to the dual meanings of
          ! "real".
          mf_fft_out_real (i, j, k, 1) = real(real (mf_data(cmplx_i, cmplx_j, cmplx_k)), c_double)
          mf_fft_out_imag (i, j, k, 1) = real(aimag(mf_data(cmplx_i, cmplx_j, cmplx_k)), c_double)
        end do
      end do
    end do

    call fftw_destroy_plan(plan)
    call fftw_free(cdata)

    ! Normalize by cell volume
    mf_fft_out_real (:, :, :, 1) = mf_fft_out_real (:, :, :, 1) * dx3
    mf_fft_out_imag (:, :, :, 1) = mf_fft_out_imag (:, :, :, 1) * dx3

end subroutine fft_3d


subroutine VorIVel(VFlag,CalcDer,G,X1,Y1,Z1,X2,Y2,Z2,XP,YP,ZP,UP,VP,WP,DUDX)

    use vortex

    real :: DVFDX, RRAT
    integer :: VFlag       ! 0 for bound vortex element, 1 for trailing wake element, 2 for spanwise wake element (sets core radius)
    integer :: CalcDer     ! 1 to calc dudx

    AX = X2-X1
    AY = Y2-Y1
    AZ = Z2-Z1
    A2 = AX**2 + AY**2 + AZ**2

    BX = X2-XP
    BY = Y2-YP
    BZ = Z2-ZP
    B = SQRT(BX**2 + BY**2 + BZ**2)

    CX = X1-XP
    CY = Y1-YP
    CZ = Z1-ZP
    C = SQRT(CX**2 + CY**2 + CZ**2)

    if (B == 0.0) then
        B = 1.0
    end if
    if (C == 0.0) then
        C = 1.0
    end if

    ADB = (AX*BX + AY*BY + AZ*BZ)
    ADBDB = ADB/B
    ADC = (AX*CX + AY*CY + AZ*CZ)
    ADCDC = ADC/C

    CCAX = CY*AZ - AY*CZ
    CCAY = AX*CZ - CX*AZ
    CCAZ = CX*AY - AX*CY

    CCAV = CCAX**2 + CCAY**2 + CCAZ**2

    ! Select the vortex core radius for bound vortex, trailing
    ! or spanwise wake elements
    if (VFlag == 1) then
        VRAD2=VRAD2_T
    else if (VFlag == 2) then
        VRAD2=VRAD2_S
    else
        VRAD2=VRAD2_B
    end if

    if (CCAV >= vCutOffRad) then
        if (ivtxcor > 0 .and. CCAV < A2*VRAD2) then
            if (ivtxcor == 1) then
                ! Constant velocity (approx) core
                CCAV = A2*VRAD2 ! limit denominator to value at core radius
                VF   = (ADBDB-ADCDC)*G/(12.56637*CCAV)
                if (CalcDer == 1) then
                    DVFDX = G/12.56637*((AX/C-CX*ADC/C**3-AX/B+BX*ADB/B**3)/CCAV)
                end if
            else if (ivtxcor == 2) then
                ! Linear velocity (approx) core
                RRAT=sqrt(CCAV/(A2*VRAD2)) ! radius to core radius ratio
                CCAV = A2*VRAD2 ! limit denominator to value at core radius
                VF   = RRAT*(ADBDB-ADCDC)*G/(12.56637*CCAV)
                if (CalcDer == 1) then
                    DVFDX = G/12.56637*((AX/C-CX*ADC/C**3-AX/B+BX*ADB/B**3)/CCAV)
                end if
            end if
        else
            VF   = (ADBDB-ADCDC)*G/(12.56637*CCAV)
            if (CalcDer == 1) then
                DVFDX = G/12.56637*((AX/C-CX*ADC/C**3-AX/B+BX*ADB/B**3)/CCAV-2*(ADBDB-ADCDC)/CCAV**2*(AZ*CCAY-AY*CCAZ))
            end if
        end if
    else
        VF   = 0.0
        DVFDX = 0.0
    end if

    UP = UP+CCAX*VF
    VP = VP+CCAY*VF
    WP = WP+CCAZ*VF
    if (CalcDer == 1) then
        DUDX = DUDX+CCAX*DVFDX
    end if

    return
end subroutine VorIVel


        SUBROUTINE RandVectOnSp3a(Mod,X,thetaX,phX)
c########################################################
c   generates uniformly distributed random             ##
c   vector on 3-sphere,with length "Mod",              ##
c   returns thetaX - polar and phX-azimuthal Angles    ##
c########################################################
          IMPLICIT NONE
          REAL             XX(2)
          DOUBLE PRECISION Mod,X(0:3),thetaX,phX
          DOUBLE PRECISION cosTh,sinTh,ph
          INCLUDE 'MC_Declare.h'

          CALL RanGen(XX,2)

          cosTh = 2d0*XX(1)-1d0
          sinTh = Dsqrt(1d0-cosTh**2)
          ph    = 2d0*pi*XX(2)

          thetaX = Dacos(cosTh)
          phX    = ph

          X(1) = Mod*sinTh*Dcos(ph)
          X(2) = Mod*sinTh*Dsin(ph)
          X(3) = Mod*cosTh

        RETURN
        END

        SUBROUTINE RandVectOnSp3b(Mod,X)
c########################################################
c       generates uniformly distributed random         ##
c        vector on 3-sphere,with length "Mod"          ##
c########################################################

          IMPLICIT NONE
          REAL             XX(2)
          DOUBLE PRECISION Mod,X(0:3)
          DOUBLE PRECISION cosTh,sinTh,ph
          INCLUDE 'MC_Declare.h'

          CALL RanGen(XX,2)

          cosTh = 2d0*XX(1)-1d0
          sinTh = Dsqrt(1d0-cosTh**2)
          ph    = 2d0*pi*XX(2)

          X(1) = Mod*sinTh*Dcos(ph)
          X(2) = Mod*sinTh*Dsin(ph)
          X(3) = Mod*cosTh

        RETURN
        END

        SUBROUTINE RandVectOnSp3_coll(Xmod,X,phaseFactor)

          IMPLICIT NONE
          REAL             XX(3)
          DOUBLE PRECISION Xmod,X(0:3),sumCharge,phaseFactor
          DOUBLE PRECISION cosTh,sinTh,ph,coeff1,coeff2,coeffS
          DOUBLE PRECISION beta1I,beta2I,beta1C,beta2C,frac2,frac1
          INCLUDE 'MC_Declare.h'

          CALL RanGen(XX,3)

          sumCharge = abs(qf1)+abs(qf2)
          beta1I = Dsqrt(1d0+(mf1/Xmod)**2)
          beta2I = Dsqrt(1d0+(mf2/Xmod)**2)
          frac1  = beta1I*abs(qf1)/sumCharge
          frac2  = beta2I*abs(qf2)/sumCharge
          coeff1 = -Dlog(((beta1I-1d0)/(beta1I+1d0))**frac1)
          coeff2 = -Dlog(((beta2I-1d0)/(beta2I+1d0))**frac2)
          coeffS = coeff1+coeff2

c... first branch -- |qf1|/|q|/(1-beta1*cosTH)
          IF (XX(1).LT.coeff1/coeffS) THEN
             beta1C = (beta1I-1d0)/(beta1I+1d0)
             cosTh  = beta1I-(beta1I+1d0)*beta1C**XX(2)
c... second  branch -- |qf2|/|q|/(1+beta2*cosTH)
          ELSE
             beta2C = (beta2I+1d0)/(beta2I-1d0)
             cosTh  = (beta2I-1d0)*beta2C**XX(2)-beta2I
          ENDIF

          sinTh= Dsqrt(1d0-cosTh**2)
          ph   = 2d0*pi*XX(3)

          X(1) = Xmod*sinTh*Dcos(ph)
          X(2) = Xmod*sinTh*Dsin(ph)
          X(3) = Xmod*cosTh

          phaseFactor=coeffS*(beta1I-cosTh)*(beta2I+cosTh)
     &                      /(beta1I*beta2I+(frac1-frac2)*cosTh) * 2d0*pi
        RETURN
        END

        SUBROUTINE RandVectOnSp3_coll_old(Xmod,X,phaseFactor)

          IMPLICIT NONE
          REAL             XX(2)
          DOUBLE PRECISION Xmod,X(0:3),phaseFactor
          DOUBLE PRECISION cosTh,sinTh,ph,r,d,betC,logBetC
          INCLUDE 'MC_Declare.h'
          CALL RanGen(XX,2)

          betC    = (X(0)+Xmod)/(X(0)-Xmod)     ! (1+bet)/(1-bet)
          logBetC = Dlog(betC)
          r       = 2d0*XX(1)-1d0
          d       = (betC)**r
          cosTh   = X(0)*(d-1d0)/(d+1d0)/Xmod
          sinTh   = Dsqrt(1d0-cosTh**2)
          ph      = 2d0*pi*XX(2)

          X(1) = Xmod*sinTh*Dcos(ph)
          X(2) = Xmod*sinTh*Dsin(ph)
          X(3) = Xmod*cosTh
c                  Jackobian corresponding to d(cosTh)  and   to d(ph)
          phaseFactor = 4d0*X(0)*d*logBetc/(d+1d0)**2/Xmod * 2d0*pi

        RETURN
        END

        DOUBLE PRECISION FUNCTION FRanGen()

          IMPLICIT NONE
          REAL rvec(1)

          CALL RanGen(rvec,1)
          FRanGen = Dble(rvec(1))

        RETURN
        END

        SUBROUTINE RanGen(RVEC,LENV)

          INTEGER          j
          DIMENSION        RVEC(LENV)
          DOUBLE PRECISION grnd
          EXTERNAL         grnd
          INCLUDE 'MC_Declare.h'

          IF (ranGenType.EQ.1) THEN
             CALL RANLUX(RVEC,LENV)              ! RANLUX
          ELSEIF (ranGenType.EQ.2) THEN
             CALL RANMAR(RVEC,LENV)              ! RANMAR
          ELSEIF (ranGenType.EQ.3) THEN
             DO j=1,LENV
                RVEC(j) = Real(grnd())           ! MERSENNE TWISTER
             ENDDO
          ELSE
             PRINT*, ""
             PRINT*, " ERROR IN RanGen():"
             PRINT*, "       THIS RANDOM GENERATOR DOES NOT EXISTS..."
             PRINT*, "          FOR INITIALIZATION SEE MC_Init():"
             PRINT*, "            RanGenType = 1 for 'ranlux'"
             PRINT*, "            RanGenType = 2 for 'ranmar'"
             PRINT*, "            RanGenType = 3 for 'mersenne twister'"
             PRINT*, ""
             STOP
          ENDIF

        RETURN
        END

      SUBROUTINE RANMAR(RVEC,LENV)
C =====================================================================
C Universal random number generator proposed by Marsaglia and Zaman
C in report FSU-SCRI-87-50
C        modified by F. James, 1988 and 1989, to generate a vector
C        of pseudorandom numbers RVEC of length LENV, and to put in
C        the COMMON block everything needed to specify currrent state,
C        and to add input and output entry points RMARIN, RMARUT.
C!!! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C!!!  Calling sequences for RANMAR:                                  ++
C!!!      CALL RANMAR (RVEC, LEN)   returns a vector RVEC of LEN     ++
C!!!                   32-bit random floating point numbers between  ++
C!!!                   zero and one.                                 ++
C!!!      CALL RMARIN(I1,N1,N2)   initializes the generator from one ++
C!!!                   32-bit integer I1, and number counts N1,N2    ++
C!!!                  (for initializing, set N1=N2=0, but to restart ++
C!!!                    a previously generated sequence, use values  ++
C!!!                    output by RMARUT)                            ++
C!!!      CALL RMARUT(I1,N1,N2)   outputs the value of the original  ++
C!!!                  seed and the two number counts, to be used     ++
C!!!                  for restarting by initializing to I1 and       ++
C!!!                  skipping N1*100000000+N2 numbers.              ++
C!!! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

      DIMENSION RVEC(*)
      COMMON/RASET1/U(97),C,I97,J97
      PARAMETER (MODCNS=1000000000)
      SAVE CD, CM, TWOM24, NTOT, NTOT2, IJKL
      DATA NTOT,NTOT2,IJKL/-1,0,0/
C
      IF (NTOT .GE. 0)  GO TO 50
C
C        Default initialization. User has called RANMAR without RMARIN.
      IJKL = 54217137
      NTOT = 0
      NTOT2 = 0
      KALLED = 0
      GO TO 1
C
      ENTRY      RMARIN(IJKLIN, NTOTIN,NTOT2N)
C         Initializing routine for RANMAR, may be called before
C         generating pseudorandom numbers with RANMAR. The input
C         values should be in the ranges:  0<=IJKLIN<=900 OOO OOO
C                                          0<=NTOTIN<=999 999 999
C                                          0<=NTOT2N<<999 999 999!
C To get the standard values in Marsaglia's paper, IJKLIN=54217137
C                                            NTOTIN,NTOT2N=0
      IJKL = IJKLIN
      NTOT = MAX(NTOTIN,0)
      NTOT2= MAX(NTOT2N,0)
      KALLED = 1
C          always come here to initialize
    1 CONTINUE
      IJ = IJKL/30082
      KL = IJKL - 30082*IJ
      I = MOD(IJ/177, 177) + 2
      J = MOD(IJ, 177)     + 2
      K = MOD(KL/169, 178) + 1
      L = MOD(KL, 169)
      WRITE(6,'(A,I10,2X,2I10)') ' RANMAR INITIALIZED:',IJKL,NTOT,NTOT2
CCC      PRINT '(A,4I10)', '   I,J,K,L= ',I,J,K,L
      DO 2 II= 1, 97
      S = 0.
      T = .5
      DO 3 JJ= 1, 24
         M = MOD(MOD(I*J,179)*K, 179)
         I = J
         J = K
         K = M
         L = MOD(53*L+1, 169)
         IF (MOD(L*M,64) .GE. 32)  S = S+T
    3    T = 0.5*T
    2 U(II) = S
      TWOM24 = 1.0
      DO 4 I24= 1, 24
    4 TWOM24 = 0.5*TWOM24
      C  =   362436.*TWOM24
      CD =  7654321.*TWOM24
      CM = 16777213.*TWOM24
      I97 = 97
      J97 = 33
C       Complete initialization by skipping
C            (NTOT2*MODCNS + NTOT) random numbers
      DO 45 LOOP2= 1, NTOT2+1
      NOW = MODCNS
      IF (LOOP2 .EQ. NTOT2+1)  NOW=NTOT
      IF (NOW .GT. 0)  THEN
        WRITE(6,'(A,I15)') ' RMARIN SKIPPING OVER ',NOW
       DO 40 IDUM = 1, NTOT
       UNI = U(I97)-U(J97)
       IF (UNI .LT. 0.)  UNI=UNI+1.
       U(I97) = UNI
       I97 = I97-1
       IF (I97 .EQ. 0)  I97=97
       J97 = J97-1
       IF (J97 .EQ. 0)  J97=97
       C = C - CD
       IF (C .LT. 0.)  C=C+CM
   40  CONTINUE
      ENDIF
   45 CONTINUE
      IF (KALLED .EQ. 1)  RETURN
C
C          Normal entry to generate LENV random numbers
   50 CONTINUE
      DO 100 IVEC= 1, LENV
      UNI = U(I97)-U(J97)
      IF (UNI .LT. 0.)  UNI=UNI+1.
      U(I97) = UNI
      I97 = I97-1
      IF (I97 .EQ. 0)  I97=97
      J97 = J97-1
      IF (J97 .EQ. 0)  J97=97
      C = C - CD
      IF (C .LT. 0.)  C=C+CM
      UNI = UNI-C
      IF (UNI .LT. 0.) UNI=UNI+1.
      RVEC(IVEC) = UNI
C             Replace exact zeros by uniform distr. *2**-24
         IF (UNI .EQ. 0.)  THEN
         ZUNI = TWOM24*U(2)
C             An exact zero here is very unlikely, but let's be safe.
         IF (ZUNI .EQ. 0.) ZUNI= TWOM24*TWOM24
         RVEC(IVEC) = ZUNI
         ENDIF
  100 CONTINUE
      NTOT = NTOT + LENV
         IF (NTOT .GE. MODCNS)  THEN
         NTOT2 = NTOT2 + 1
         NTOT = NTOT - MODCNS
         ENDIF
      RETURN
C           Entry to output current status
      ENTRY RMARUT(IJKLUT,NTOTUT,NTOT2T)
      IJKLUT = IJKL
      NTOTUT = NTOT
      NTOT2T = NTOT2
      RETURN
      END

      SUBROUTINE RANLUX(RVEC,LENV)
C         Subtract-and-borrow random number generator proposed by
C         Marsaglia and Zaman, implemented by F. James with the name
C         RCARRY in 1991, and later improved by Martin Luescher
C         in 1993 to produce "Luxury Pseudorandom Numbers".
C     Fortran 77 coded by F. James, 1993
C
C       references:
C  M. Luscher, Computer Physics Communications  79 (1994) 100
C  F. James, Computer Physics Communications 79 (1994) 111
C
C   LUXURY LEVELS.
C   ------ ------      The available luxury levels are:
C
C  level 0  (p=24): equivalent to the original RCARRY of Marsaglia
C           and Zaman, very long period, but fails many tests.
C  level 1  (p=48): considerable improvement in quality over level 0,
C           now passes the gap test, but still fails spectral test.
C  level 2  (p=97): passes all known tests, but theoretically still
C           defective.
C  level 3  (p=223): DEFAULT VALUE.  Any theoretically possible
C           correlations have very small chance of being observed.
C  level 4  (p=389): highest possible luxury, all 24 bits chaotic.
C
C!!! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C!!!  Calling sequences for RANLUX:                                  ++
C!!!      CALL RANLUX (RVEC, LEN)   returns a vector RVEC of LEN     ++
C!!!                   32-bit random floating point numbers between  ++
C!!!                   zero (not included) and one (also not incl.). ++
C!!!      CALL RLUXGO(LUX,INT,K1,K2) initializes the generator from  ++
C!!!               one 32-bit integer INT and sets Luxury Level LUX  ++
C!!!               which is integer between zero and MAXLEV, or if   ++
C!!!               LUX .GT. 24, it sets p=LUX directly.  K1 and K2   ++
C!!!               should be set to zero unless restarting at a break++
C!!!               point given by output of RLUXAT (see RLUXAT).     ++
C!!!      CALL RLUXAT(LUX,INT,K1,K2) gets the values of four integers++
C!!!               which can be used to restart the RANLUX generator ++
C!!!               at the current point by calling RLUXGO.  K1 and K2++
C!!!               specify how many numbers were generated since the ++
C!!!               initialization with LUX and INT.  The restarting  ++
C!!!               skips over  K1+K2*E9   numbers, so it can be long.++
C!!!   A more efficient but less convenient way of restarting is by: ++
C!!!      CALL RLUXIN(ISVEC)    restarts the generator from vector   ++
C!!!                   ISVEC of 25 32-bit integers (see RLUXUT)      ++
C!!!      CALL RLUXUT(ISVEC)    outputs the current values of the 25 ++
C!!!                 32-bit integer seeds, to be used for restarting ++
C!!!      ISVEC must be dimensioned 25 in the calling program        ++
C!!! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      DIMENSION RVEC(LENV)
      DIMENSION SEEDS(24), ISEEDS(24), ISDEXT(25)
      PARAMETER (MAXLEV=4, LXDFLT=3)
      DIMENSION NDSKIP(0:MAXLEV)
      DIMENSION NEXT(24)
      PARAMETER (TWOP12=4096., IGIGA=1000000000,JSDFLT=314159265)
      PARAMETER (ITWO24=2**24, ICONS=2147483563)
      SAVE NOTYET, I24, J24, CARRY, SEEDS, TWOM24, TWOM12, LUXLEV
      SAVE NSKIP, NDSKIP, IN24, NEXT, KOUNT, MKOUNT, INSEED
      INTEGER LUXLEV
      LOGICAL NOTYET
      DATA NOTYET, LUXLEV, IN24, KOUNT, MKOUNT /.TRUE., LXDFLT, 0,0,0/
      DATA I24,J24,CARRY/24,10,0./
C                               default
C  Luxury Level   0     1     2   *3*    4
      DATA NDSKIP/0,   24,   73,  199,  365 /
Corresponds to p=24    48    97   223   389
C     time factor 1     2     3     6    10   on slow workstation
C                 1    1.5    2     3     5   on fast mainframe
C
C  NOTYET is .TRUE. if no initialization has been performed yet.
C              Default Initialization by Multiplicative Congruential
      IF (NOTYET) THEN
         NOTYET = .FALSE.
         JSEED = JSDFLT
         INSEED = JSEED
c         WRITE(6,'(A,I12)') ' RANLUX DEFAULT INITIALIZATION: ',JSEED
         LUXLEV = LXDFLT
         NSKIP = NDSKIP(LUXLEV)
         LP = NSKIP + 24
         IN24 = 0
         KOUNT = 0
         MKOUNT = 0
c         WRITE(6,'(A,I2,A,I4)')  ' RANLUX DEFAULT LUXURY LEVEL =  ',
c     +        LUXLEV,'      p =',LP
            TWOM24 = 1.
         DO 25 I= 1, 24
            TWOM24 = TWOM24 * 0.5
         K = JSEED/53668
         JSEED = 40014*(JSEED-K*53668) -K*12211
         IF (JSEED .LT. 0)  JSEED = JSEED+ICONS
         ISEEDS(I) = MOD(JSEED,ITWO24)
   25    CONTINUE
         TWOM12 = TWOM24 * 4096.
         DO 50 I= 1,24
         SEEDS(I) = REAL(ISEEDS(I))*TWOM24
         NEXT(I) = I-1
   50    CONTINUE
         NEXT(1) = 24
         I24 = 24
         J24 = 10
         CARRY = 0.
         IF (SEEDS(24) .EQ. 0.) CARRY = TWOM24
      ENDIF
C
C          The Generator proper: "Subtract-with-borrow",
C          as proposed by Marsaglia and Zaman,
C          Florida State University, March, 1989
C
      DO 100 IVEC= 1, LENV
      UNI = SEEDS(J24) - SEEDS(I24) - CARRY
      IF (UNI .LT. 0.)  THEN
         UNI = UNI + 1.0
         CARRY = TWOM24
      ELSE
         CARRY = 0.
      ENDIF
      SEEDS(I24) = UNI
      I24 = NEXT(I24)
      J24 = NEXT(J24)
      RVEC(IVEC) = UNI
C  small numbers (with less than 12 "significant" bits) are "padded".
      IF (UNI .LT. TWOM12)  THEN
         RVEC(IVEC) = RVEC(IVEC) + TWOM24*SEEDS(J24)
C        and zero is forbidden in case someone takes a logarithm
         IF (RVEC(IVEC) .EQ. 0.)  RVEC(IVEC) = TWOM24*TWOM24
      ENDIF
C        Skipping to luxury.  As proposed by Martin Luscher.
      IN24 = IN24 + 1
      IF (IN24 .EQ. 24)  THEN
         IN24 = 0
         KOUNT = KOUNT + NSKIP
         DO 90 ISK= 1, NSKIP
         UNI = SEEDS(J24) - SEEDS(I24) - CARRY
         IF (UNI .LT. 0.)  THEN
            UNI = UNI + 1.0
            CARRY = TWOM24
         ELSE
            CARRY = 0.
         ENDIF
         SEEDS(I24) = UNI
         I24 = NEXT(I24)
         J24 = NEXT(J24)
   90    CONTINUE
      ENDIF
  100 CONTINUE
      KOUNT = KOUNT + LENV
      IF (KOUNT .GE. IGIGA)  THEN
         MKOUNT = MKOUNT + 1
         KOUNT = KOUNT - IGIGA
      ENDIF
      RETURN
C
C           Entry to input and float integer seeds from previous run
      ENTRY RLUXIN(ISDEXT)
*     IF block added by Phillip Helbig after correpondence with James
      IF (NOTYET) THEN
         WRITE(6,'(A)')  ' PROPER RESULTS ONLY WITH INITIALISATION FROM
     $25 INTEGERS OBTAINED WITH RLUXUT'
         NOTYET = .FALSE.
      ENDIF
         TWOM24 = 1.
         DO 195 I= 1, 24
         NEXT(I) = I-1
  195    TWOM24 = TWOM24 * 0.5
         NEXT(1) = 24
         TWOM12 = TWOM24 * 4096.
      WRITE(6,'(A)') ' FULL INITIALIZATION OF RANLUX WITH 25 INTEGERS:'
      WRITE(6,'(5X,5I12)') ISDEXT
      DO 200 I= 1, 24
      SEEDS(I) = REAL(ISDEXT(I))*TWOM24
  200 CONTINUE
      CARRY = 0.
      IF (ISDEXT(25) .LT. 0)  CARRY = TWOM24
      ISD = IABS(ISDEXT(25))
      I24 = MOD(ISD,100)
      ISD = ISD/100
      J24 = MOD(ISD,100)
      ISD = ISD/100
      IN24 = MOD(ISD,100)
      ISD = ISD/100
      LUXLEV = ISD
        IF (LUXLEV .LE. MAXLEV) THEN
          NSKIP = NDSKIP(LUXLEV)
          WRITE (6,'(A,I2)') ' RANLUX LUXURY LEVEL SET BY RLUXIN TO: ',
     +                         LUXLEV
        ELSE  IF (LUXLEV .GE. 24) THEN
          NSKIP = LUXLEV - 24
          WRITE (6,'(A,I5)') ' RANLUX P-VALUE SET BY RLUXIN TO:',LUXLEV
        ELSE
          NSKIP = NDSKIP(MAXLEV)
          WRITE (6,'(A,I5)') ' RANLUX ILLEGAL LUXURY RLUXIN: ',LUXLEV
          LUXLEV = MAXLEV
        ENDIF
      INSEED = -1
      RETURN
C
C                    Entry to ouput seeds as integers
      ENTRY RLUXUT(ISDEXT)
      DO 300 I= 1, 24
         ISDEXT(I) = INT(SEEDS(I)*TWOP12*TWOP12)
  300 CONTINUE
      ISDEXT(25) = I24 + 100*J24 + 10000*IN24 + 1000000*LUXLEV
      IF (CARRY .GT. 0.)  ISDEXT(25) = -ISDEXT(25)
      RETURN
C
C                    Entry to output the "convenient" restart point
      ENTRY RLUXAT(LOUT,INOUT,K1,K2)
      LOUT = LUXLEV
      INOUT = INSEED
      K1 = KOUNT
      K2 = MKOUNT
      RETURN
C
C                    Entry to initialize from one or three integers
      ENTRY RLUXGO(LUX,INS,K1,K2)
         IF (LUX .LT. 0) THEN
            LUXLEV = LXDFLT
         ELSE IF (LUX .LE. MAXLEV) THEN
            LUXLEV = LUX
         ELSE IF (LUX .LT. 24 .OR. LUX .GT. 2000) THEN
            LUXLEV = MAXLEV
            WRITE (6,'(A,I7)') ' RANLUX ILLEGAL LUXURY RLUXGO: ',LUX
         ELSE
            LUXLEV = LUX
            DO 310 ILX= 0, MAXLEV
              IF (LUX .EQ. NDSKIP(ILX)+24)  LUXLEV = ILX
  310       CONTINUE
         ENDIF
      IF (LUXLEV .LE. MAXLEV)  THEN
         NSKIP = NDSKIP(LUXLEV)
         WRITE(6,'(A,I2,A,I4)') ' RANLUX LUXURY LEVEL SET BY RLUXGO :',
     +        LUXLEV,'     P=', NSKIP+24
      ELSE
          NSKIP = LUXLEV - 24
          WRITE (6,'(A,I5)') ' RANLUX P-VALUE SET BY RLUXGO TO:',LUXLEV
      ENDIF
      IN24 = 0
      IF (INS .LT. 0)  WRITE (6,'(A)')
     +   ' Illegal initialization by RLUXGO, negative input seed'
      IF (INS .GT. 0)  THEN
        JSEED = INS
        WRITE(6,'(A,3I12)') ' RANLUX INITIALIZED BY RLUXGO FROM SEEDS',
     +      JSEED, K1,K2
      ELSE
        JSEED = JSDFLT
        WRITE(6,'(A)')' RANLUX INITIALIZED BY RLUXGO FROM DEFAULT SEED'
      ENDIF
      INSEED = JSEED
      NOTYET = .FALSE.
      TWOM24 = 1.
         DO 325 I= 1, 24
           TWOM24 = TWOM24 * 0.5
         K = JSEED/53668
         JSEED = 40014*(JSEED-K*53668) -K*12211
         IF (JSEED .LT. 0)  JSEED = JSEED+ICONS
         ISEEDS(I) = MOD(JSEED,ITWO24)
  325    CONTINUE
      TWOM12 = TWOM24 * 4096.
         DO 350 I= 1,24
         SEEDS(I) = REAL(ISEEDS(I))*TWOM24
         NEXT(I) = I-1
  350    CONTINUE
      NEXT(1) = 24
      I24 = 24
      J24 = 10
      CARRY = 0.
      IF (SEEDS(24) .EQ. 0.) CARRY = TWOM24
C        If restarting at a break point, skip K1 + IGIGA*K2
C        Note that this is the number of numbers delivered to
C        the user PLUS the number skipped (if luxury .GT. 0).
      KOUNT = K1
      MKOUNT = K2
      IF (K1+K2 .NE. 0)  THEN
        DO 500 IOUTER= 1, K2+1
          INNER = IGIGA
          IF (IOUTER .EQ. K2+1)  INNER = K1
          DO 450 ISK= 1, INNER
            UNI = SEEDS(J24) - SEEDS(I24) - CARRY
            IF (UNI .LT. 0.)  THEN
               UNI = UNI + 1.0
               CARRY = TWOM24
            ELSE
               CARRY = 0.
            ENDIF
            SEEDS(I24) = UNI
            I24 = NEXT(I24)
            J24 = NEXT(J24)
  450     CONTINUE
  500   CONTINUE
C         Get the right value of IN24 by direct calculation
        IN24 = MOD(KOUNT, NSKIP+24)
        IF (MKOUNT .GT. 0)  THEN
           IZIP = MOD(IGIGA, NSKIP+24)
           IZIP2 = MKOUNT*IZIP + IN24
           IN24 = MOD(IZIP2, NSKIP+24)
        ENDIF
C       Now IN24 had better be between zero and 23 inclusive
        IF (IN24 .GT. 23) THEN
           WRITE (6,'(A/A,3I11,A,I5)')
     +    '  Error in RESTARTING with RLUXGO:','  The values', INS,
     +     K1, K2, ' cannot occur at luxury level', LUXLEV
           IN24 = 0
        ENDIF
      ENDIF
      RETURN
      END

*##############################################################
*                MERSENNE TWISTER
*==============================================================
* A C-program for MT19937: Real number version
*   genrand() generates one pseudorandom real number (double)
* which is uniformly distributed on [0,1]-interval, for each
* call. sgenrand(seed) set initial values to the working area
* of 624 words. Before genrand(), sgenrand(seed) must be
* called once. (seed is any 32-bit integer except for 0).
* Integer generator is obtained by modifying two lines.
*   Coded by Takuji Nishimura, considering the suggestions by
* Topher Cooper and Marc Rieffel in July-Aug. 1997.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Library General Public
* License as published by the Free Software Foundation; either
* version 2 of the License, or (at your option) any later
* version.
* This library is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
* See the GNU Library General Public License for more details.
* You should have received a copy of the GNU Library General
* Public License along with this library; if not, write to the
* Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
* 02111-1307  USA
*
* Copyright (C) 1997 Makoto Matsumoto and Takuji Nishimura.
* When you use this, send an email to: matumoto@math.keio.ac.jp
* with an appropriate reference to your work.
*
************************************************************************
* Fortran translation by Hiroshi Takano.  Jan. 13, 1999.
*
*   genrand()      -> double precision function grnd()
*   sgenrand(seed) -> subroutine sgrnd(seed)
*                     integer seed
*
* This program uses the following non-standard intrinsics.
*   ishft(i,n): If n>0, shifts bits in i by n positions to left.
*               If n<0, shifts bits in i by n positions to right.
*   iand (i,j): Performs logical AND on corresponding bits of i and j.
*   ior  (i,j): Performs inclusive OR on corresponding bits of i and j.
*   ieor (i,j): Performs exclusive OR on corresponding bits of i and j.
*
************************************************************************
      subroutine sgrnd(seed)
*
      implicit integer(a-z)
*
* Period parameters
      parameter(N     =  624)
*
      dimension mt(0:N-1)
*                     the array for the state vector
      common /block/mti,mt
      save   /block/
*
*      setting initial seeds to mt[N] using
*      the generator Line 25 of Table 1 in
*      [KNUTH 1981, The Art of Computer Programming
*         Vol. 2 (2nd Ed.), pp102]
*
      mt(0)= iand(seed,-1)
      do 1000 mti=1,N-1
        mt(mti) = iand(69069 * mt(mti-1),-1)
 1000 continue
*
      return
      end
************************************************************************
      double precision function grnd()
*
      implicit integer(a-z)
*
* Period parameters
      parameter(N     =  624)
      parameter(N1    =  N+1)
      parameter(M     =  397)
      parameter(MATA  = -1727483681)
*                                    constant vector a
      parameter(UMASK = -2147483647)
*                                    most significant w-r bits
      parameter(LMASK =  2147483647)
*                                    least significant r bits
* Tempering parameters
      parameter(TMASKB= -1658038656)
      parameter(TMASKC= -272236544)
*
      dimension mt(0:N-1)
*                     the array for the state vector
      common /block/mti,mt
      save   /block/
      data   mti/N1/
*                     mti==N+1 means mt[N] is not initialized
*
      dimension mag01(0:1)
      data mag01/0, MATA/
      save mag01
*                        mag01(x) = x * MATA for x=0,1
*
      TSHFTU(y)=ishft(y,-11)
      TSHFTS(y)=ishft(y,7)
      TSHFTT(y)=ishft(y,15)
      TSHFTL(y)=ishft(y,-18)
*
      if(mti.ge.N) then
*                       generate N words at one time
        if(mti.eq.N+1) then
*                            if sgrnd() has not been called,
          call sgrnd(4357)
*                              a default initial seed is used
        endif
*
        do 1000 kk=0,N-M-1
            y=ior(iand(mt(kk),UMASK),iand(mt(kk+1),LMASK))
            mt(kk)=ieor(ieor(mt(kk+M),ishft(y,-1)),mag01(iand(y,1)))
 1000   continue
        do 1100 kk=N-M,N-2
            y=ior(iand(mt(kk),UMASK),iand(mt(kk+1),LMASK))
            mt(kk)=ieor(ieor(mt(kk+(M-N)),ishft(y,-1)),mag01(iand(y,1)))
 1100   continue
        y=ior(iand(mt(N-1),UMASK),iand(mt(0),LMASK))
        mt(N-1)=ieor(ieor(mt(M-1),ishft(y,-1)),mag01(iand(y,1)))
        mti = 0
      endif
*
      y=mt(mti)
      mti=mti+1
      y=ieor(y,TSHFTU(y))
      y=ieor(y,iand(TSHFTS(y),TMASKB))
      y=ieor(y,iand(TSHFTT(y),TMASKC))
      y=ieor(y,TSHFTL(y))
*
      if(y.lt.0) then
        grnd=(dble(y)+2.0d0**32)/(2.0d0**32-1.0d0)
      else
        grnd=dble(y)/(2.0d0**32-1.0d0)
      endif
*
      return
      end


      SUBROUTINE PHO_DOR94HO(X,Q2,Uv,Dv,Del,Udb,Sb,Gl)
C
C...NLO PARAMETRIZATION (MS(BAR)) :
C

      IMPLICIT NONE
      DOUBLE PRECISION ad , ae , ag , agx , akd , ake , akg , aks ,
     &                 aku , akx , alg , als , alx , as , au , bd , be ,
     &                 beg , bes , bex
      DOUBLE PRECISION bg , bgx , bkd , bke , bkg , bku , bkx , bs ,
     &                 bu , cd , ce , cg , cu , cx , dd , de , Del ,
     &                 dg , ds , dst
      DOUBLE PRECISION du , Dv , dx , eg , esg , ess , est , esx , ex ,
     &                 Gl , lam2 , mu2 , nd , ne , nu , PHO_DOR94FS ,
     &                 PHO_DOR94FV , PHO_DOR94FW , Q2 , s
      DOUBLE PRECISION s2 , s3 , Sb , Udb , Uv , X
      SAVE

      mu2 = 0.34
      lam2 = 0.248*0.248
      s = LOG(LOG(Q2/lam2)/LOG(mu2/lam2))
      ds = SQRT(s)
      s2 = s*s
      s3 = s2*s
C...UV :
      nu = 1.304 + 0.863*s
      aku = 0.558 - 0.020*s
      bku = 0.183*s
      au = -0.113 + 0.283*s - 0.321*s2
      bu = 6.843 - 5.089*s + 2.647*s2 - 0.527*s3
      cu = 7.771 - 10.09*s + 2.630*s2
      du = 3.315 + 1.145*s - 0.583*s2 + 0.154*s3
      Uv = PHO_DOR94FV(X,nu,aku,bku,au,bu,cu,du)
C...DV :
      nd = 0.102 - 0.017*s + 0.005*s2
      akd = 0.270 - 0.019*s
      bkd = 0.260
      ad = 2.393 + 6.228*s - 0.881*s2
      bd = 46.06 + 4.673*s - 14.98*s2 + 1.331*s3
      cd = 17.83 - 53.47*s + 21.24*s2
      dd = 4.081 + 0.976*s - 0.485*s2 + 0.152*s3
      Dv = PHO_DOR94FV(X,nd,akd,bkd,ad,bd,cd,dd)
C...DEL :
      ne = 0.070 + 0.042*s - 0.011*s2 + 0.004*s3
      ake = 0.409 - 0.007*s
      bke = 0.782 + 0.082*s
      ae = -29.65 + 26.49*s + 5.429*s2
      be = 90.20 - 74.97*s + 4.526*s2
      ce = 0.0
      de = 8.122 + 2.120*s - 1.088*s2 + 0.231*s3
      Del = PHO_DOR94FV(X,ne,ake,bke,ae,be,ce,de)
C...UDB :
      alx = 0.877
      bex = 0.561
      akx = 0.275
      bkx = 0.0
      agx = 0.997
      bgx = 3.210 - 1.866*s
      cx = 7.300
      dx = 9.010 + 0.896*ds + 0.222*s2
      ex = 3.077 + 1.446*s
      esx = 3.173 - 2.445*ds + 2.207*s
      Udb = PHO_DOR94FW(X,s,alx,bex,akx,bkx,agx,bgx,cx,dx,ex,esx)
C...SB :
      als = 0.756
      bes = 0.216
      aks = 1.690 + 0.650*ds - 0.922*s
      as = -4.329 + 1.131*s
      bs = 9.568 - 1.744*s
      dst = 9.377 + 1.088*ds - 1.320*s + 0.130*s2
      est = 3.031 + 1.639*s
      ess = 5.837 + 0.815*s
      Sb = PHO_DOR94FS(X,s,als,bes,aks,as,bs,dst,est,ess)
C...GL :
      alg = 1.014
      beg = 1.738
      akg = 1.724 + 0.157*s
      bkg = 0.800 + 1.016*s
      ag = 7.517 - 2.547*s
      bg = 34.09 - 52.21*ds + 17.47*s
      cg = 4.039 + 1.491*s
      dg = 3.404 + 0.830*s
      eg = -1.112 + 3.438*s - 0.302*s2
      esg = 3.256 - 0.436*s
      Gl = PHO_DOR94FW(X,s,alg,beg,akg,bkg,ag,bg,cg,dg,eg,esg)

      END SUBROUTINE


      subroutine runP_i(k,i1,f,Gr,Shat2,N0)
      implicit none
      include 'pvDnames.f'
      include 'pvDv.f'
      include 'Darraydef.f'
      include 'Darrays.f'
      integer ep,N0,k,i1,np
      parameter(np=3)
      double precision f(np),Gr(np,np)
      double complex Shat2(np,np,-2:0)

      do ep=-2,0
      Dv(di(i1)+N0,ep)=
     . (Shat2(k,i1,ep)
     . -2d0*delta(k,i1)*Dv(dd00+N0,ep)
     . -Gr(k,1)*Dv(dii(z2(1,i1))+N0,ep)
     . -Gr(k,2)*Dv(dii(z2(2,i1))+N0,ep)
     . -Gr(k,3)*Dv(dii(z2(3,i1))+N0,ep))/f(k)
      enddo

      return
      end