cc      SUBROUTINE SPGRH(Y,N,MODE)
      SUBROUTINE SPGRHF(Y,N,LAGH1,IFPL1,MODE,PERIOD,CXX,CN,XMEAN,SD,AIC,
     *                   PARCOR,PXX,IER)
c
      INCLUDE 'timsac_f.h'
cc      !DEC$ ATTRIBUTES DLLEXPORT::SPGRHF
c
cxx      IMPLICIT REAL*8(A-H,O-Z)
cc      INTEGER H,H1
cxx      INTEGER PERIOD
CC      REAL*4 X,SXX,BMYA,BMYM
cc      DIMENSION Y(1)
cc      DIMENSION X(4000),CXX(1001)
cc      DIMENSION A(101),B(101)
cc      DIMENSION SXX(501)
cxx      DIMENSION Y(N)
cxx      DIMENSION CXX(LAGH1),CN(LAGH1)
cxx      DIMENSION A(IFPL1),B(IFPL1)
cxx      DIMENSION PXX(LAGH1)
cxx      DIMENSION SD(IFPL1),AIC(IFPL1),PARCOR(IFPL1-1)
      INTEGER :: N, LAGH1, IFPL1, MODE, PERIOD, IER
      REAL(8) :: Y(N), CXX(LAGH1), CN(LAGH1), XMEAN, SD(IFPL1),
     1           AIC(IFPL1), PARCOR(IFPL1-1), PXX(LAGH1)
      REAL(8) :: A(IFPL1), B(IFPL1), SGME2, OAIC
C
cc      H=60
cc      H1=H+1
C
cc      DO 10 I=1,N
cc      X(I)=Y(I)
cc   10 CONTINUE
C
C     AUTO COVARIANCE COMPUTATION.
cc      LAGH=N-1
cc      LAGH=MIN0(LAGH,60)
cc      LAGH1=LAGH+1
cc      CALL SAUTCO(X,CXX,N,LAGH1)
      CALL AUTCORF(Y,N,CXX,CN,LAGH1,XMEAN)
cc      AN=N
cc      IFPL=3.0D-00*DSQRT(AN)
cc      IFPL=MIN0(IFPL,50,LAGH)
cc      IFPL=MIN0(30,N-1)
cc      IFPL1=IFPL+1
cc      CALL SICP2(CXX,IFPL1,N,A,L,SGME2,OAIC)
      CALL SICP2(CXX,IFPL1,N,A,L,SGME2,OAIC,SD,AIC,PARCOR,IER)
      IF(MODE .EQ. 0) RETURN
cc      WRITE(6,50)
      K=0
cc 1031 CALL SNRASP(A,B,SXX,SGME2,L,K,H1,BMYA,BMYM)
cxx 1031 CALL SNRASP(A,B,PXX,SGME2,L,K,LAGH1,PERIOD)
      CALL SNRASP(A,B,PXX,SGME2,L,K,LAGH1,PERIOD)
C
      RETURN
cxx   50 FORMAT(1H ,'*** HIGH ORDER AR-SPECTRUM AS AN APPROXIMATION TO PERI
cxx     *ODGRAM (ORDER IS FIXED AT 30 ) ***')
      END
cc      SUBROUTINE SICP2(CYY,L1,N,COEF,MO,OSD,OAIC)
      SUBROUTINE SICP2(CYY,L1,N,COEF,MO,OSD,OAIC,SD1,AIC1,PARCOR,IER)
C     COMMON SUBROUTINE
C     THIS SUBROUTINE FITS AUTOREGRESSIVE MODELS OF SUCCESSIVELY
C     INCREASING ORDER UP TO L(=L1-1).
C     INPUT:
C     CYY(I),I=0,L1; AUTOCOVARIANCE SEQUENCE
C     L1: L1=L+1, L IS THE UPPER LIMIT OF THE MODEL ORDER
C     N; LENGTH OF ORIGINAL DATA
C     OUT PUT:
C     COEF; AR-COEFFICIENTS
C     MO: ORDER OF AR
C     OSD: INNOVATION VARIANCE
C     OAIC: VALUE OF AIC
cxx      IMPLICIT REAL*8(A-H,O-Z)
cxx      DIMENSION CYY(L1),COEF(L1)
cc      DIMENSION A(101),B(101)
cxx      DIMENSION A(L1),B(L1)
cxx      DIMENSION SD1(L1),AIC1(L1),PARCOR(L1-1)
      INTEGER :: L1, N, MO, IER
      REAL(8) :: CYY(L1), COEF(L1), OSD, OAIC, SD1(L1), AIC1(L1),
     1           PARCOR(L1-1)
      REAL(8) :: A(L1), B(L1), CST0, CST1, CST2, CST20, CST05, CST01,
     1           SD, AN, RAN, SCALH, AIC, SE, SDR, D, D2, AM, ANFC
cc      REAL*4 AX,BL,STA,DASH,PLUS
cc      REAL*4 FFFF
cc      REAL*4  F(41) / 41*1H  /, AMES(41) / 41*1H- /
cc      DATA AX,BL,STA,DASH,PLUS/1H!,1H ,1H*,1H-,1H+/
c-----
      IER=0
c-----
      CST0=0.0D-00
      CST1=1.0D-00
      CST2=2.0D-00
      CST20=20.0D-00
      CST05=0.05D-00
      CST01=0.00001D-00
      L=L1-1
      SD=CYY(1)
      AN=N
      OAIC=AN*DLOG(SD)
      OSD=SD
      MO=0
C     INITIAL CONDITION PRINT OUT
cc  991 CONTINUE
C     WRITE(6,1100)
      RAN=CST1/DSQRT(AN)
      SCALH=CST20
cxx      JJ0=SCALH+CST1
cxx      JJL=SCALH*CST2+CST1
      JJ0=INT(SCALH+CST1)
      JJL=INT(SCALH*CST2+CST1)
cc      AMES(1)=PLUS
cc      AMES(11)=PLUS
cc      AMES(JJ0)=PLUS
cc      AMES(JJ0+10)=PLUS
cc      AMES(JJL)=PLUS
cxx      IAN=SCALH*(RAN+CST05)
      IAN=INT(SCALH*(RAN+CST05))
      IAN1=IAN+JJ0
      IAN2=2*IAN+JJ0
      LAN1=-IAN+JJ0
      LAN2=-2*IAN+JJ0
C     WRITE(6,26100)
cc      WRITE(6,26101)
cc      WRITE(6,261)
cc      WRITE(6,26102)
cc      WRITE(6,262)
cc      WRITE(6,264) (AMES(J),J=1,JJL)
cc      WRITE(6,859) MO,OSD,OAIC
      SD1(MO+1)=OSD
      AIC1(MO+1)=OAIC
c-----
      AIC=OAIC
c-----
cc      F(JJ0)=AX
cc      F(IAN1)=AX
cc      F(IAN2)=AX
cc      F(LAN1)=AX
cc      F(LAN2)=AX
cc      WRITE(6,861) (F(J),J=1,JJL)
      SE=CYY(2)
C     ITERATION START
      DO 400 M=1,L
      SDR=SD/CYY(1)
      IF(SDR.GE.CST01) GO TO 399
cc      WRITE(6,2600)
c-----
      IER=2600
c-----
      GO TO 402
  399 MP1=M+1
      D=SE/SD
      A(M)=D
      D2=D*D
      SD=(CST1-D2)*SD
      AM=M
      AIC=AN*DLOG(SD)+CST2*AM
      IF(M.EQ.1) GO TO 410
C     A(I) COMPUTATION
      LM=M-1
      DO 420 I=1,LM
      A(I)=A(I)-D*B(I)
  420 CONTINUE
  410 CONTINUE
      DO 421 I=1,M
      IM=MP1-I
cxx  421 B(I)=A(IM)
      B(I)=A(IM)
  421 CONTINUE
C     M,SD,AIC  PRINT OUT
      IF(A(M).LT.CST0) GO TO 300
cxx      NFC=SCALH*(A(M)+CST05)
      NFC=INT(SCALH*(A(M)+CST05))
      GO TO 310
cxx  300 NFC=SCALH*(A(M)-CST05)
  300 NFC=INT(SCALH*(A(M)-CST05))
  310 ANFC=NFC
cxx      JJ=ANFC+SCALH+CST1
      JJ=INT(ANFC+SCALH+CST1)
cc      FFFF=F(JJ)
cc      F(JJ)=STA
cc      WRITE(6,860) M,SD,AIC,A(M),(F(J),J=1,JJL)
      SD1(M+1)=SD
      AIC1(M+1)=AIC
      PARCOR(M)=A(M)
cc      F(JJ)=FFFF
C
cxx  990 IF(OAIC.LT.AIC) GO TO 440
      IF(OAIC.LT.AIC) GO TO 440
      OAIC=AIC
      OSD=SD
      MO=M
      GO TO 440
C     DO 430 I=1,M
C 430 COEF(I)=-A(I)
  440 IF(M.EQ.L) GO TO 400
      SE=CYY(M+2)
      DO 441 I=1,M
cxx  441 SE=SE-B(I)*CYY(I+1)
      SE=SE-B(I)*CYY(I+1)
  441 CONTINUE
  400 CONTINUE
  402 CONTINUE
cc      WRITE(6,870) OAIC,MO
      OAIC=AIC
      OSD=SD
      MO=L
      DO 5100 I=1,L
cxx 5100 COEF(I)=-A(I)
      COEF(I)=-A(I)
 5100 CONTINUE
C
C     MO, COEF(I) OUT PUT
C     WRITE(6,1871)
C     WRITE(6,871)
C     CALL SUBVCP(COEF,MO)
cc  699 F(JJ0)=BL
cc      F(IAN1)=BL
cc      F(IAN2)=BL
cc      F(LAN1)=BL
cc      F(LAN2)=BL
cc      AMES(JJ0)=DASH
cc      AMES(JJ0+10)=DASH
cc      AMES(JJL)=DASH
      RETURN
cxx26100 FORMAT(1H ,16X,'SD(M)',15X,'AIC(M)',13X,'A(M)')
cxx26101 FORMAT(1H ,////,4X,'M',11X,'INNOVATION',10X,'AIC(M)=    ',8X,
cxx     A      'PARTIAL AUTO-')
cxx  261 FORMAT(1H ,16X,'   VARIANCE',9X,'N*DLOG(SD(M))+2*M',
cxx     A      '  CORRELATION    ',
cxx     A      'PARTIAL CORRELATION (LINES SHOW +SD AND +2SD)')
cxx26102 FORMAT(1H+,102X,'_',7X,'_')
cxx  262 FORMAT(1H ,69X,'-1',19X,'0',19X,'1')
cxx  264 FORMAT(1H ,70X,41A1)
cxx  859 FORMAT(1H ,I5,2X,2D20.5)
cxx  860 FORMAT(1H ,I5,2X,3D20.5,3X,41A1)
cxx  861 FORMAT(1H+,70X,41A1)
cxx  960 FORMAT(1H ,5X,'A(I)')
cxx  870 FORMAT(/,1H ,'MINIMUM AIC(M)=',D12.5,2X,'ATTAINED AT M=',I5/)
cxx  980 FORMAT(1H ,5X,'COEF(I)')
cxx 1100 FORMAT(1H ,'AIC(M)=N*DLOG(SD)+2*M')
cxx  871 FORMAT(1H ,'AR-COEFFICIENTS')
cxx 1871 FORMAT(1H ,'AR MODEL: Y(N)+AR(1)Y(N-1)+...+AR(M)Y(N-M)=X(N)')
cxx 2600 FORMAT(1H ,'ACCURACY OF COMPUTATION LOST')
      END
cc      SUBROUTINE SNRASP(A,B,SXX,SGME2,L,K,H1,BMYA,BMYM)
      SUBROUTINE SNRASP(A,B,PXX,SGME2,L,K,H1,IPPP)
C     THIS PROGRAM COMPUTES POWER SPECTRUM OF AN AR-MA PROCESS DEFINED B
C     X(N)=A(1)X(N-1)+...+A(L)X(N-L)+E(N)+B(1)E(N-1)+...+B(K)E(N-K),
C     WHERE E(N) IS A WHITE NOISE WITH ZERO MEAN AND VARIANCE EQUAL TO
C     SGME2.  OUTPUTS PXX(I) ARE GIVEN AT FREQUENCIES I/(2*H)
C     I=0,1,...,H.
C     REQUIRED INPUTS ARE:
C     L,K,H,SGME2,(A(I),I=1,L), AND (B(I),I=1,K).
C     0 IS ALLOWABLE AS L AND/OR K.
cxx      IMPLICIT REAL*8(A-H,O-Z)
cc      INTEGER H,H1
cxx      INTEGER H1
CC      REAL*4 SXX,BMYA,BMYM,FY
cc      REAL*4 FY
cc      INTEGER F,AX,BL,STA
cc      DIMENSION F(61),FY(10)
cc      DIMENSION A(101),B(101)
cc      DIMENSION G(501),GR1(501),GI1(501),GR2(501),GI2(501)
cc      DIMENSION PXX(501),SXX(501)
cxx      DIMENSION A(L),B(K)
cxx      DIMENSION G(L+K+1),GR1(H1),GI1(H1),GR2(H1),GI2(H1)
cxx      DIMENSION PXX(H1)
      INTEGER :: L, K, H1, IPPP
      REAL(8) :: A(L), B(K), PXX(H1), SGME2
      REAL(8) :: G(L+K+1), GR1(H1), GI1(H1), GR2(H1), GI2(H1),
     1           CST0, CST1, T0
cc      COMMON /ILOGT/IDUMMY(2),IPUNC
cc      COMMON /IDATA/IPPP
cc      DATA AX/1H!/
cc      DATA BL,STA/1H ,1H*/
      IPPP0=120/IPPP
      CST0=0.0D-00
      CST1=1.0D-00
cxx  310 CONTINUE
      IF(L.LE.0) GO TO 320
      DO 330 I=1,L
cxx  330 A(I)=-A(I)
      A(I)=-A(I)
  330 CONTINUE
  320 L1=L+1
      K1=K+1
      G(1)=CST1
      IF(L.LE.0) GO TO 400
      DO 10 I=1,L
      I1=I+1
cxx   10 G(I1)=-A(I)
      G(I1)=-A(I)
   10 CONTINUE
C     COMMON SUBROUTINE CALL
  400 CALL FOUGER(G,L1,GR1,GI1,H1)
      G(1)=CST1
      IF(K.LE.0) GO TO 410
      DO 20 I=1,K
      I1=I+1
cxx   20 G(I1)=B(I)
      G(I1)=B(I)
   20 CONTINUE
C     COMMON SUBROUTINE CALL
  410 CALL FOUGER(G,K1,GR2,GI2,H1)
      DO 30 I=1,H1
cxx   30 PXX(I)=(GR2(I)**2+GI2(I)**2)/(GR1(I)**2+GI1(I)**2)*SGME2
      PXX(I)=(GR2(I)**2+GI2(I)**2)/(GR1(I)**2+GI1(I)**2)*SGME2
   30 CONTINUE
C     WRITE(6,60)
C     WRITE(6,160)
C     WRITE(6,61) L,K,H
C     WRITE(6,164) SGME2
C     WRITE(6,264)
C     WRITE(6,265)
      IF(L.LE.0) GO TO 500
      DO 340 I=1,L
cxx  340 A(I)=-A(I)
      A(I)=-A(I)
  340 CONTINUE
C     WRITE(6,62)
C     COMMON SUBROUTINE CALL
C     CALL SUBVCP(A,L)
  500 IF(K.LE.0) GO TO 510
cc      WRITE(6,63)
C     COMMON SUBROUTINE CALL
cc      CALL SUBVCP(B,K)
  510 T0=CST0
cc      DO 520 I=1,H1
cc      T=PXX(I)
cc      IF(T.LT.T0) T=-T
cc  520 SXX(I)=DLOG10(T)
C     SEARCH  FOR THE MAXIMUM AND MINIMUM OF (SXX(I),I=0,LAGH)
cc      CALL DSP3(SXX,H1,BMYA,BMYM)
cc      WRITE(6,266)
cc  266 FORMAT(1H ,47X,'(DENSITY IN DB)')
cc      FY(1)=BMYM*10.0
cc      DO 2031 I=2,7
cc 2031 FY(I)=FY(I-1)+10.0
cc      WRITE(6,2033) (FY(I),I=1,7)
cc 2033 FORMAT(1H ,25X,6(F5.1,5X),F5.1)
cc      WRITE(6,67)
cc   67 FORMAT(1H ,4X,'I',1X,'RATIONAL SPECTRUM')
cc      WRITE(6,2035)
cc 2035 FORMAT(1H+,28X,6('+',9('-')),'+')
cc      DO 2050 J=1,61
cc 2050 F(J)=BL
cc      DO 2040 I=1,H1
cc      IT=(SXX(I)-BMYM)*10.0+1.0
cc      IM1=I-1
cc      F(1)=AX
cc      F(IT)=STA
cc      WRITE(6,2060) IM1,PXX(I),(F(J),J=1,61)
cc      MODP=MOD(IM1,IPPP0)
cc      IF(MODP .EQ. 0) WRITE(6,1600)
cc 1600 FORMAT(1H+,90X,'----X')
cc      IF(IM1 .EQ. 5) WRITE(6,1601)
cc 1601 FORMAT(1H+,98X,'X: IF PEAKS(TROUGHS) APPEAR')
cc      IF(IM1 .EQ. 6) WRITE(6,1602)
cc 1602 FORMAT(1H+,101X,'AT THESE FRIQUENCIES,')
cc      IF(IM1 .EQ. 7) WRITE(6,1603)
cc 1603 FORMAT(1H+,101X,'TRY LOWER(HIGHER) VALUES')
cc      IF(IM1 .EQ. 8) WRITE(6,1604)
cc 1604 FORMAT(1H+,101X,'OF RIGID AND WATCH ABIC')
cc      IF(IM1 .EQ. 42 .AND. IPPP .EQ. 12) WRITE(6,1605)
cc 1605 FORMAT(1H+,90X,'----- IF A PEAK APPEARS HERE')
cc      IF(IM1 .EQ. 43 .AND. IPPP .EQ. 12) WRITE(6,1606)
cc 1606 FORMAT(1H+,101X,'TRY TRADING-DAY ADJUSTMENT')
cc      F(IT)=BL
cc 2040 CONTINUE
cc 2060 FORMAT(1H ,I5,2X,D14.5,7X,61A1)
cc      IF(IPUNC .EQ. 0) RETURN
C
cc      WRITE(7,700) H1
cc      WRITE(7,701)
cc      WRITE(7,702) (SXX(I),I=1,H1)
cc  700 FORMAT(I5)
cc  701 FORMAT('(6D12.5)')
cc  702 FORMAT(6D12.5)
      RETURN
cxx   60 FORMAT(//1H ,'RATIONAL SPECTRUM')
cxx   61 FORMAT(1H ,2HL=,I5,2X,2HK=,I5,2X,2HH=,I5)
cxx   62 FORMAT(1H ,5X,'AR(I)')
cxx   63 FORMAT(1H ,5X,'MA(I)')
cxx  160 FORMAT(1H ,17HINITIAL CONDITION)
cxx  164 FORMAT(1H ,6HSGME2=,D12.5)
cxx  264 FORMAT(1H ,'AR-MA MODEL:')
cxx  265 FORMAT(1H ,'Y(N)+AR(1)Y(N-1)+...+AR(L)Y(N-L)=X(N)+MA(1)X(N-1)+...+
cxx     AMA(K)X(N-K)')
      END


      subroutine eullag3(itp,xxi,yyi,zzi,xxj,yyj,zzj,xix,xiy,xiz,
     *     xoa,xob,xoc)
!***********************************************************************
!  Copyright, 2004,  The  Regents  of the  University of California.
!  This program was prepared by the Regents of the University of
!  California at Los Alamos National Laboratory (the University) under
!  contract No. W-7405-ENG-36 with the U.S. Department of Energy (DOE).
!  All rights in the program are reserved by the DOE and the University.
!  Permission is granted to the public to copy and use this software
!  without charge, provided that this Notice and any statement of
!  authorship are reproduced on all copies. Neither the U.S. Government
!  nor the University makes any warranty, express or implied, or
!  assumes any liability or responsibility for the use of this software.
C**********************************************************************
CD1
CD1 PURPOSE
CD1
CD1 this routine converts between two geometric reference frames
CD1 given a point i(xxi,yyi,zzi) and a nearest neighbor j(xxj,yyj,zzj)
CD1 along with a vector (xix,xiy,xiz) do a rotation of this
CD1 vector form x,y,z space to a,b,c space.
CD1      itp = 1 ==> x,y,z to a,b,c
CD1      itp= 2 ==> a,b,c to x,y,z
CD1
C**********************************************************************
CD2
CD2 REVISION HISTORY
CD2
CD2 Revision                    ECD
CD2 Date         Programmer     Number  Comments
CD2
CD2 25-APR-96    S. Henderson   22      Initial implementation
CD2
CD2 $Log:   /pvcs.config/fehm90/src/eullag3.f_a  $
!D2
!D2    Rev 2.5   06 Jan 2004 10:42:58   pvcs
!D2 FEHM Version 2.21, STN 10086-2.21-00, Qualified October 2003
!D2
!D2    Rev 2.4   29 Jan 2003 09:03:22   pvcs
!D2 FEHM Version 2.20, STN 10086-2.20-00
!D2
!D2    Rev 2.3   14 Nov 2001 13:08:56   pvcs
!D2 FEHM Version 2.12, STN 10086-2.12-00
!D2
!D2    Rev 2.2   06 Jun 2001 13:23:42   pvcs
!D2 FEHM Version 2.11, STN 10086-2.11-00
!D2
!D2    Rev 2.1   30 Nov 2000 12:01:00   pvcs
!D2 FEHM Version 2.10, STN 10086-2.10-00
!D2
!D2    Rev 2.0   Fri May 07 14:41:12 1999   pvcs
!D2 FEHM Version 2.0, SC-194 (Fortran 90)
CD2
CD2    Rev 1.1   Wed Jun 26 12:37:50 1996   hend
CD2 Updated Prolog
CD2
CD2    Rev 1.0   Thu Apr 25 13:34:24 1996   hend
CD2 Initial coding for use in long/trans dispersion
CD2
C**********************************************************************
CD3
CD3 REQUIREMENTS TRACEABILITY
CD3
CD3 2.3.4 Solute-transport equations
CD3
C**********************************************************************
CD4
CD4 SPECIAL COMMENTS
CD4
CD4 Requirements from SDN: 10086-RD-2.20-00
CD4   SOFTWARE REQUIREMENTS DOCUMENT (RD) for the
CD4   FEHM Application Version 2.20
CD4
CD4 This code is part of X3D
CD4
C**********************************************************************

      implicit none

      integer itp
      real*8  xxi,yyi,zzi,xxj,yyj,zzj,xix,xiy,xiz,xoa,xob,xoc
      real*8  sinph,cosph,sinth,costh
      real*8  a11,a12,a13,a21,a22,a23,a31,a32,a33
      real*8  ai11,ai12,ai13,ai21,ai22,ai23,ai31,ai32,ai33
      character*132 logmess

      call angle3(xxi,yyi,zzi,xxj,yyj,zzj,sinph,cosph,sinth,costh)
      goto (100,200) itp
100   continue
      a11=cosph
      a12=sinph
      a13=0.0
      a21=-costh*sinph
      a22=costh*cosph
      a23=sinth
      a31=sinth*sinph
      a32=-sinth*cosph
      a33=costh
      xoa=a11*xix+a12*xiy+a13*xiz
      xob=a21*xix+a22*xiy+a23*xiz
      xoc=a31*xix+a32*xiy+a33*xiz
      goto 9999
200   continue
      ai11=cosph
      ai12=-sinph*costh
      ai13=sinph*sinth
      ai21=sinph
      ai22=cosph*costh
      ai23=-cosph*sinth
      ai31=0.0
      ai32=sinth
      ai33=costh
      xoa=ai11*xix+ai12*xiy+ai13*xiz
      xob=ai21*xix+ai22*xiy+ai23*xiz
      xoc=ai31*xix+ai32*xiy+ai33*xiz
      goto 9999
9999  continue
      return
      end


      SUBROUTINE MB03GZ( Z11, Z12, Z22, H11, H12, CO1, SI1, CO2, SI2 )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To compute a unitary matrix Q and a unitary symplectic matrix U
C     for a complex regular 2-by-2 skew-Hamiltonian/Hamiltonian pencil
C     aS - bH with S = J Z' J' Z, where
C
C            (  Z11  Z12  )         (  H11  H12  )
C        Z = (            ) and H = (            ),
C            (   0   Z22  )         (   0  -H11' )
C
C     such that U' Z Q, (J Q J' )' H Q are both upper triangular, but the
C     eigenvalues of (J Q J')' ( aS - bH ) Q are in reversed order.
C     The matrices Q and U are represented by
C
C            (  CO1  SI1  )         (  CO2  SI2  )
C        Q = (            ) and U = (            ), respectively.
C            ( -SI1' CO1  )         ( -SI2' CO2  )
C
C     The notation M' denotes the conjugate transpose of the matrix M.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     Z11     (input) COMPLEX*16
C             Upper left element of the non-trivial factor Z in the
C             factorization of S.
C
C     Z12     (input) COMPLEX*16
C             Upper right element of the non-trivial factor Z in the
C             factorization of S.
C
C     Z22     (input) COMPLEX*16
C             Lower right element of the non-trivial factor Z in the
C             factorization of S.
C
C     H11     (input) COMPLEX*16
C             Upper left element of the Hamiltonian matrix H.
C
C     H12     (input) COMPLEX*16
C             Upper right element of the Hamiltonian matrix H.
C
C     CO1     (output) DOUBLE PRECISION
C             Upper left element of Q.
C
C     SI1     (output) COMPLEX*16
C             Upper right element of Q.
C
C     CO2     (output) DOUBLE PRECISION
C             Upper left element of U.
C
C     SI2     (output) COMPLEX*16
C             Upper right element of U.
C
C     METHOD
C
C     The algorithm uses unitary and unitary symplectic transformations
C     as described on page 37 in [1].
C
C     REFERENCES
C
C     [1] Benner, P., Byers, R., Mehrmann, V. and Xu, H.
C         Numerical Computation of Deflating Subspaces of Embedded
C         Hamiltonian Pencils.
C         Tech. Rep. SFB393/99-15, Technical University Chemnitz,
C         Germany, June 1999.
C
C     NUMERICAL ASPECTS
C
C     The algorithm is numerically backward stable.
C
C     CONTRIBUTOR
C
C     Matthias Voigt, Fakultaet fuer Mathematik, Technische Universitaet
C     Chemnitz, April 21, 2009.
C
C     REVISIONS
C
C     V. Sima, Aug. 2009 (SLICOT version of the routine ZHAFEX).
C     V. Sima, Dec. 2010.
C     M. Voigt, Jan. 2012.
C
C     KEYWORDS
C
C     Eigenvalue exchange, skew-Hamiltonian/Hamiltonian pencil, upper
C     triangular matrix.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   TWO
      PARAMETER          ( TWO = 2.0D+0 )
C
C     .. Scalar Arguments ..
      DOUBLE PRECISION   CO1, CO2
      COMPLEX*16         H11, H12, SI1, SI2, Z11, Z12, Z22
C
C     .. Local Scalars ..
      COMPLEX*16         D, G, TMP
C
C     .. External Subroutines ..
      EXTERNAL           ZLARTG
C
C     .. Intrinsic Functions ..
      INTRINSIC          CONJG, DBLE
C
C     .. Executable Statements ..
C
C     Computations.
C
      G = TWO*DBLE( H11*CONJG( Z11 )*Z22 )
      D = Z22*CONJG( Z11 )*H12 +
     $      ( CONJG( Z22 )*Z12 - CONJG( Z12 )*Z22 )*CONJG( H11 )
      CALL ZLARTG( D, G, CO1, SI1, TMP )
      D =  Z11*CO1 - Z12*CONJG( SI1 )
      G = -Z22*CONJG( SI1 )
      CALL ZLARTG( D, G, CO2, SI2, TMP )
      SI2 = -SI2
C
      RETURN
C *** Last line of MB03GZ ***
      END


#include "../defines.inc"
!---------------------------------------------------!
!
!   This module calculates linking number (Lk), twist (Tw)
!   , and writhe (Wr) after each move and from scratch by
!   Lk = Tw + Wr
!
!   This module does not support multi-chain simulation
!
!           Kao 08/22/2019
!
!---------------------------------------------------!

module linkingNumber
   use precision, only: dp, pi, eps
   implicit none
contains

! Calculate linking number of the whole ring from scratch
   subroutine link_twist_writhe_from_scratch()
      use params, only: wlc_R, wlc_U, wlc_V, wlc_LkScratch, wlc_TwScratch, &
                        wlc_WrScratch
      implicit none
      call calc_tw(wlc_U, wlc_V, wlc_TwScratch)
      call WRITHE(wlc_R, WLC_P__NB, wlc_WrScratch)
      wlc_LkScratch = wlc_TwScratch + wlc_WrScratch
   end subroutine

! Calculate change in twist, writhe, and linking number
   subroutine get_del_tw_wr_lk(IB1, IB2, MCTYPE, delTw, delWr, delLk)
      implicit none
      integer, intent(in) :: IB1
      integer, intent(in) :: IB2
      integer, intent(in) :: MCTYPE
      real(dp), intent(out) :: delTw
      real(dp), intent(out) :: delWr
      real(dp), intent(out) :: delLk

      if (MCTYPE == 2) then
         ! mc_slide doesn't change twist
         delTw = 0.0_dp
      else
         delTw = getDelTw()
      endif
      if (MCTYPE == 4) then
         ! mc_rotate doesn't change writhe
         delWr = 0.0_dp
      else
         delWr = getDelWr(IB1, IB2, WLC_P__NB)
      endif
      delLk = delTw + delWr
   end subroutine

! ----------------- Helper functions/subroutine -----------------!
! Calculate twist of the whole ring using triad twist approach
! This is a helper subroutine of link_twist_writhe_from_scratch
   subroutine calc_tw(U, V, Tw)
      implicit none
      real(dp), intent(in), dimension(:, :) :: U  ! tangent vectors
      real(dp), intent(in), dimension(:, :) :: V  ! binormal vectors
      real(dp), intent(out) :: Tw     ! result twist (turns)
      integer IT          ! bead index that goes around a ring
      integer ITP1        ! index of bead next to IT

      Tw = 0.0_dp
      do IT = 1, WLC_P__NB
         if (IT < WLC_P__NB) then
            ITP1 = IT + 1
         else
            ITP1 = 1
         endif
         Tw = Tw + oneLinkTriadTwist(U(:, IT), V(:, IT), U(:, ITP1), V(:, ITP1))
      enddo
   end subroutine

! Calculate change in twist after a move using triad twist approach
! This is a helper function of delTw_Wr_Lk
   function getDelTw() result(delTw)
      use params, only: wlc_nBend, wlc_bendPoints, wlc_U, wlc_V, wlc_UP, wlc_VP
      use ringHelper, only: nextBead
      implicit none
      real(dp) delTw      ! result change in twist
      real(dp) oldTw      ! twist of bendPoints before the move
      real(dp) newTw      ! twist of bendPoints after the move
      integer IT          ! bead index
      integer ITP1        ! index of the bead next to IT
      integer I

      oldTw = 0.0_dp
      newTw = 0.0_dp
      do I = 1, wlc_nBend
         IT = wlc_bendPoints(I)
         ITP1 = nextBead(IT)
         oldTw = oldTw + oneLinkTriadTwist(wlc_U(:, IT), wlc_V(:, IT), wlc_U(:, ITP1), wlc_V(:, ITP1))
         newTw = newTw + oneLinkTriadTwist(wlc_UP(:, IT), wlc_VP(:, IT), wlc_UP(:, ITP1), wlc_VP(:, ITP1))
      enddo
      delTw = newTw - oldTw
   end function

! Calculate twist between two triads
! Helper function to calculate twist with triad twist approach
   function oneLinkTriadTwist(U, V, UP1, VP1) result(Tw)
      use vector_utils, only: cross
      implicit none
      real(dp) Tw     ! result twist (turns)
      real(dp), intent(in), dimension(3) :: U     ! tangent of i-th bead
      real(dp), intent(in), dimension(3) :: V     ! binormal of i-th bead
      real(dp), intent(in), dimension(3) :: UP1   ! tangent of i+1-th bead
      real(dp), intent(in), dimension(3) :: VP1   ! binormal of i+1-th bead

      real(dp) F(3)       ! normal of i-th bead
      real(dp) FP1(3)   ! normal of i+1-th bead

      F = cross(V, U)
      FP1 = cross(VP1, UP1)

      Tw = atan2(dot_product(V, FP1) - dot_product(F, VP1), &
                 dot_product(F, FP1) + dot_producT(V, VP1))
      Tw = Tw/(2.0_dp*pi)
   end function

! Calculate change in writhe after each move by evaluating the
! changed integrand of the double integral described in Klenin (2000)
! Method 1 before and after a move.
   function getDelWr(IB1, IB2, N) result(delWr)
      use ringHelper, only: nextBead, prevBead
      implicit none
      real(dp) delWr      ! the result total change in writhe
      integer, intent(in) :: IB1      ! local index of first bead that moved
      integer, intent(in) :: IB2      ! local index of last bead that moved
      integer, intent(in) :: N        ! number of beads in the ring
      integer NBI     ! Number of inner segments
      integer NBO     ! Number of outer segments
      integer I      ! bead index for iteration
      integer II
      integer J      ! bead index for iteration
      integer JJ

! Denote a chain segment by the starting bead
! e.g. segment IB1 means R(:, IB1 + 1) - R(:, IB1)
! Call the segments that moved as inner segments
! Call the segments that don't move as outer segments
! To iterate through every changed integrand (Omega),
! we nead to pair the inner segments up among themselves, and pair
! each inner segment with all outer segments since writhe calculation
! is the double integral of Omega.
! Note that all move segments are prevBead(IB1) through IB2
      delWr = 0.0_dp
! Find the length of inner and outer segments
      if (IB2 >= IB1) then
         NBI = IB2 - IB1 + 2
         NBO = N - NBI
      else
         NBO = IB1 - IB2 - 2
         NBI = N - NBO
      endif

! Iterate through inner segments
      I = prevBead(IB1)
      do II = 1, NBI
         J = nextBead(I)
         do JJ = 1, NBI - II
            delWr = delWr + delWrithePair(I, J)
            J = nextBead(J)
         enddo
         I = nextBead(I)
      enddo

! Iterate through outer segments
      I = nextBead(IB2)
      do II = 1, NBO
         J = prevBead(IB1)
         do JJ = 1, NBI
            delWr = delWr + delWrithePair(I, J)
            J = nextBead(J)
         enddo
         I = nextBead(I)
      enddo

      delWr = 2.0_dp*delWr
   end function

! This is a helper function of getDelWr.
! Evaluate the change in writhe integrand (Omega) of a pair
! of chain segments after a move.
   function delWrithePair(I1, I2) result(delOmega)
      use params, only: wlc_R, wlc_RP
      use ringHelper, only: nextBead
      implicit none
      real(dp) delOmega      ! the result change in integrand
      integer, intent(in) :: I1        ! index of first segment
      integer, intent(in) :: I2        ! index of second segment
      real(dp) Omega      ! Integrand of a pair of segment before move
      real(dp) OmegaP     ! Integrand of a pair of segment after move
      integer I1P1        ! index of bead next to I1
      integer I2P1        ! index of bead next to I2
      real(dp) RPI1(3)    ! position of proposed position at I1
      real(dp) RPI1P1(3)  ! position of proposed position at I1P1
      real(dp) RPI2(3)    ! position of proposed position at I2
      real(dp) RPI2P1(3)  ! position of proposed position at I2P1

      I1P1 = nextBead(I1)
      I2P1 = nextBead(I2)
      if (I1P1 == I2 .or. I2P1 == I1) then
         ! Since Omega(i, i) = Omega(i, i+1) = 0
         delOmega = 0.0_dp
      else
         Omega = dWrithe_Klenin1b(wlc_R(:, I1), wlc_R(:, I1P1), &
                                  wlc_R(:, I2), wlc_R(:, I2P1))
         ! If RP(:, I) is nan, that bead doesn't move; we use R(:, I) instead.
         if (isnan(wlc_RP(1, I1))) then
            RPI1 = wlc_R(:, I1)
         else
            RPI1 = wlc_RP(:, I1)
         endif
         if (isnan(wlc_RP(1, I1P1))) then
            RPI1P1 = wlc_R(:, I1P1)
         else
            RPI1P1 = wlc_RP(:, I1P1)
         endif
         if (isnan(wlc_RP(1, I2))) then
            RPI2 = wlc_R(:, I2)
         else
            RPI2 = wlc_RP(:, I2)
         endif
         if (isnan(wlc_RP(1, I2P1))) then
            RPI2P1 = wlc_R(:, I2P1)
         else
            RPI2P1 = wlc_RP(:, I2P1)
         endif
         OmegaP = dWrithe_Klenin1b(RPI1, RPI1P1, RPI2, RPI2P1)
         delOmega = OmegaP - Omega
      endif
   end function

! This function find the value of the integrand for each pair of
! chain segment using Method 1b described  in Klenin (2000)
! Look at Brad's util/writhe.f03 for reference
   function dWrithe_Klenin1b(r1, r1P1, r2, r2P1) result(Omega)
      use vector_utils, only: cross
      implicit none
      real(dp) Omega      ! the result integrand (solid angle)
      real(dp), intent(in), dimension(3) ::  r1(3)        ! Position bead 1
      real(dp), intent(in), dimension(3) ::  r1P1(3)      ! Position bead next to bead 1
      real(dp), intent(in), dimension(3) ::  r2(3)        ! Position bead 2
      real(dp), intent(in), dimension(3) ::  r2P1(3)      ! Position bead next to bead 2
      real(dp) r12(3)            ! Relative position vector
      real(dp) s1                ! Length of segment 1
      real(dp) s2                ! Length of segment 2
      real(dp) beta              ! Angle between tangents
      real(dp) e1(3)             ! Tangent of first segment
      real(dp) e2(3)             ! Tangent of second segment
      real(dp) cosB
      real(dp) sin2B
      real(dp) unit_cross(3)
      real(dp) a0
      real(dp) a1
      real(dp) a2
      real(dp) a3
!Variables for writhe integral
      real(dp) t1
      real(dp) t2
      real(dp) F1
      real(dp) F2
      real(dp) F3
      real(dp) F4

      r12 = r2 - r1
      s1 = SQRT(SUM((r1P1 - r1)**2))
      s2 = SQRT(SUM((r2P1 - r2)**2))
      e1 = (r1P1 - r1)/s1
      e2 = (r2P1 - r2)/s2

      cosB = doT_PRODUCT(e1, e2)
      sin2B = 1.0_dp - (cosB**2.0_dp)
!B = ACOS(cosB)
!sin2B = sin(B)**2.

      unit_cross = cross(e1, e2)

      if (abs(sin2B) .lt. (eps)) then
         sin2b = 0.0_dp
      endif

      a1 = doT_PRODUCT(r12, e2*cosB - e1)/sin2B
      a2 = doT_PRODUCT(r12, e2 - e1*cosB)/sin2B
      a0 = doT_PRODUCT(r12, unit_cross)/sin2B

      t1 = a1 + s1
      t2 = a2 + s2
      F1 = -ATAN((t1*t2 + (a0**2.)*cosB)/(a0*SQRT((t1**2.+t2**2.-2.*t1*t2*cosB + (a0**2.)*sin2B))))/(4.*PI)
      t1 = a1 + s1
      t2 = a2
      F2 = -ATAN((t1*t2 + (a0**2.)*cosB)/(a0*SQRT((t1**2.+t2**2.-2.*t1*t2*cosB + (a0**2.)*sin2B))))/(4.*PI)
      t1 = a1
      t2 = a2 + s2
      F3 = -ATAN((t1*t2 + (a0**2.)*cosB)/(a0*SQRT((t1**2.+t2**2.-2.*t1*t2*cosB + (a0**2.)*sin2B))))/(4.*PI)
      t1 = a1
      t2 = a2
      F4 = -ATAN((t1*t2 + (a0**2.)*cosB)/(a0*SQRT((t1**2.+t2**2.-2.*t1*t2*cosB + (a0**2.)*sin2B))))/(4.*PI)
      Omega = F1 - F2 - F3 + F4

      if (Omega /= Omega) then
         Omega = 0.0_dp
      endif

      if (abs(a0) < 10.0_dp**(-10.0_dp)) then
         Omega = 0.0_dp
      endif
   end function

! --------------- Test functions/subroutine ---------------!
! Calculate delLk with total chain calculation
   function getDelLkTest() result(delLk)
      implicit none
      real(dp) delLk
      real(dp) delTw
      real(dp) delWr

      delTw = getDelTwTest()
      delWr = getDelWrTest()
      delLk = delTw + delWr
   end function

! Calculate delTw with calculating total twist
   function getDelTwTest() result(delTw)
      use params, only: wlc_U, wlc_V, wlc_UP, wlc_VP
      implicit none
      real(dp) oldTw
      real(dp) newTw
      real(dp) delTw

      call calc_tw(wlc_U, wlc_V, oldTw)
      call calc_tw(wlc_UP, wlc_VP, newTw)
      delTw = newTw - oldTw
   end function

! Calculate change in writhe after each move by evaluating Wr before
! and after the move. Note that to use this function, all wlc_R
! must be copied to wlc_RP so that there is no nan in the unmoved RP
   function getDelWrTest() result(delWr)
      use params, only: wlc_R, wlc_RP
      implicit none
      real(dp) oldWr
      real(dp) newWr
      real(dp) delWr

      call WRITHE(wlc_R, WLC_P__NB, oldWr)
      call WRITHE(wlc_RP, WLC_P__NB, newWr)
      delWr = newWr - oldWr
   end function

end module linkingNumber


subroutine vertvel(rr,ia,ja,ka,imt,jmt,km,ff,uflux,vflux,do3d,wflux)
!====================================================================
! Calculate the vertical flux based on the uflux and vflux
!
!  Input:
!    rr             : time interpolation constant between 0 and 1. Controls how much
!                   : of earlier time step is used in interpolation.
!    ia,ja,ka       : original position in integers
!    imt,jmt,km     : grid index sizing constants in (x,y,z), are for
!                     horizontal and vertical rho grid [scalar]
!    ff             : time direction. ff=1 forward, ff=-1 backward
!    uflux          : u velocity (zonal) flux field, two time steps [ixjxkxt]
!    vflux          : v velocity (meridional) flux field, two time steps [ixjxkxt]
!    do3d           : Flag to set whether to use 3d velocities or not
!
!  Output:
!    wflux          : w velocity (vertical) flux field, two time steps [kxt]
!
!  Other parameters used in function:
!    rg             : rg=1-rr for time interpolation between time steps. Controls how much
!                   : of later time step is used in interpolation.
!    uu             : time-interpolated flux at ia/ja/ka (depending on ijk)
!    um             : time-interpolated flux at ia-1/ja-1/ka-1 (depending on ijk)
!    nsm=1,nsp=2    : Time index. nsm picks out the earlier bounding time step and
!                     nsp picks out the later bounding time step for interpolation.
!    iam            : generic index for grid index -1 for whichever direction, ijk.
!                     Is only used in the i direction for whatever reason.
!    k              : Index for looping through depth layers
!    n              : Index for looping through times (1 and 2)
!
!  Notes:
!    Computes the vertical velocity by integrating the continuity eq. from the bottom
!    for the nsm and nsp velocity time steps.
!    This is set up to use neither the -full_wflux nor -explicit_w flags currently,
!    just the default w flux option.
!====================================================================

implicit none

integer,        intent(in)                                      :: ff,ia,ja,ka,imt,jmt,km
integer,        intent(in)                                      :: do3d
real(kind=8),   intent(in)                                      :: rr
real(kind=8),   intent(in),     dimension(imt-1,jmt,km,2)       :: uflux
real(kind=8),   intent(in),     dimension(imt,jmt-1,km,2)       :: vflux
real(kind=8),   intent(out),    dimension(0:km,2)               :: wflux
real(kind=8)                                                    :: rg
! real(kind=8)                                                    :: uu,um,rg
integer                                                         :: nsm=1,nsp=2,k,n,iam

rg=1.d0-rr
wflux=0.d0
iam=ia-1

! print *,'in vertvel'
! print '(a,i3,a,i3,a,i3)','ia=',ia,&
!     ' ja=',ja,' ka=',ka
! print *,'imt=',imt,' jmt=',jmt,' km=',km
! print *,'size(uflux)=',size(uflux,1),' size(vflux)=',size(vflux,1)

if(do3d==0) then
    return

! start 3D code
else
    kloop: do k=1,ka
  ! these only need to be defined if we use full_wflux, which we aren't doing right now
!      uu=rg*uflux(ia ,ja  ,k,nsp)+rr*uflux(ia ,ja  ,k,nsm)
!      um=rg*uflux(iam,ja  ,k,nsp)+rr*uflux(iam,ja  ,k,nsm)
!      vv=rg*vflux(ia ,ja  ,k,nsp)+rr*vflux(ia ,ja  ,k,nsm)
!      vm=rg*vflux(ia ,ja-1,k,nsp)+rr*vflux(ia ,ja-1,k,nsm)

! ! start ifs code
! #if defined ifs
!     do n=nsm,nsp
!      wflux(k,n) = wflux(k-1,n) - ff * &
!      ( uflux(ia,ja,k,n) - uflux(iam,ja,k,n) + vflux(ia,ja,k,n) - vflux(ia,ja-1,k,n)  &
!      + (dzt(ia,ja,k,nsp)-dzt(ia,ja,k,nsm))*dxdy(ia,ja)/tseas )  ! time change of the mass the in grid box
!     enddo
! #endif
! ! end ifs code

! start ocean code
! #ifdef  full_wflux
!      wflux(ia,ja,k,nsm)=wflux(ia,ja,k-1,nsm) - ff * ( uu - um + vv - vm )
! #else
        do n=nsm,nsp
            wflux(k,n) = wflux(k-1,n) - ff * &
                        ( uflux(ia,ja,k,n) - uflux(iam,ja,k,n) + &
                        vflux(ia,ja,k,n) - vflux(ia,ja-1,k,n) )
        enddo
! #endif
!end ocean code
    end do kloop

endif
! end 3D code

!#endif
  return
end subroutine vertvel


      FUNCTION ALG9 (H,S,V2)
C
      COMMON /GAS/ G,EJ,R,CP,GAMMA,ROJCP
C
      ALG9=CP*V2/(GAMMA*G*R*H)
      RETURN
      END


!***************************************************************************************************
! xnet_constants.f90 10/18/17
! This file contains numerical and physical constants used by XNet.
!***************************************************************************************************

Module xnet_constants
  !-------------------------------------------------------------------------------------------------
  ! These are fundamental, astrophysical, and numerical constants CGS units, except energies in MeV,
  ! temperature in GK.
  !-------------------------------------------------------------------------------------------------
  Use xnet_types, Only: dp
  Implicit None

  ! Some commonly used fractions and logarithms
  Real(dp), Parameter :: third   = 1.0 / 3.0
  Real(dp), Parameter :: two3rd  = 2.0 / 3.0
  Real(dp), Parameter :: four3rd = 4.0 / 3.0
  Real(dp), Parameter :: five3rd = 5.0 / 3.0
  Real(dp), Parameter :: log_e   = log10(exp(1.0))
  Real(dp), Parameter :: ln_2    = log(2.0)
  Real(dp), Parameter :: ln_10   = log(10.0)

  ! 71 digits of pi (256-bit precision)
  Real(dp), Parameter :: pi      = 3.1415926535897932384626433832795028841971693993751058209749445923078164
  Real(dp), Parameter :: pi2     = pi * pi

  ! Fundamental constants (CODATA recommended 2014 values)
  ! P. J. Mohr, D. B. Newell, and B. N. Taylor, Rev. Mod. Phys. 88, 035009 (2016)
  ! http://physics.nist.gov/cuu/Constants/Table/allascii.txt
  Real(dp), Parameter :: clt     = 2.99792458e+10   ! Speed of light in vacuum [cm s^{-1}]
  Real(dp), Parameter :: hbar    = 6.582119514e-22  ! Plank constants, reduced [MeV s]
  Real(dp), Parameter :: avn     = 6.022140857e+23  ! Avogadro constant [mol^{-1}]
  Real(dp), Parameter :: bok     = 8.6173303e-02    ! Boltzmann constant [MeV GK^{-1}]
  Real(dp), Parameter :: epmev   = 1.6021766208e-06 ! MeV to erg conversion factor [erg MeV^{-1}]
  Real(dp), Parameter :: m_e     = 0.5109989461     ! Electron mass [MeV c^{-2}]
  Real(dp), Parameter :: m_n     = 939.5654133      ! Neutron mass [MeV c^{-2}]
  Real(dp), Parameter :: m_p     = 938.2720813      ! Proton mass [MeV c^{-2}]
  Real(dp), Parameter :: ele_en  = m_e              ! Electron mass [MeV c^{-2}]
  Real(dp), Parameter :: asig    = 8.563456e+31     ! Radiation constant [cm^{-3} MeV^{-3}]

  ! Some derived constants
  Real(dp), Parameter :: amu     = 1.0/(avn*epmev)      ! = 1.036426957e-18 ! Atomic mass unit [MeV]
  Real(dp), Parameter :: m_u     = amu * clt**2         ! = 931.4940954     ! Atomic mass unit [MeV c^{-2}]
  Real(dp), Parameter :: e2      = 1.0e-28*epmev*clt**2 ! = 1.439964533e-13 ! (elementary charge)^2 [MeV^2]
  Real(dp), Parameter :: emass   = m_e / clt**2         ! Electron mass [MeV]

  ! Screening factors from Table 4 of Graboske+ (1973)
  Real(dp), Parameter   :: bw = 1.0,  kbw = 0.5            ! Weak screening parameters
  Real(dp), Parameter   :: bi = 0.86, kbi = 0.38           ! Intermediate screening parmaeters
  Real(dp), Parameter   :: bip1 = 1.86                     ! bi + 1
  Real(dp), Parameter   :: thbim1 = 1.58                   ! 3*bi - 1
  Real(dp), Parameter   :: thbim2 = 0.58                   ! 3*bi - 2
  Real(dp), Parameter   :: twm2bi = 0.28                   ! 2 - 2*bi

  ! Strong screening fitting coefficients from DeWitt & Slattery (2003), Eq. 4:
  !   f(gamma) = a*gamma + (1/s)*b*gamma^s + c*ln(gamma) + d
  Real(dp), Parameter   :: cds(5) = (/ -0.899172, 0.602249, -0.274823, -1.401915, 0.3230064 /)

End Module xnet_constants


SUBROUTINE mixproc(u,nlay,xcomp,cmass,mass)
!
IMPLICIT NONE
!
INCLUDE 'p1werm.inc'
!
! Subroutine arguments
!
REAL :: cmass,mass,u
INTEGER :: nlay
REAL,DIMENSION(mnsz) :: xcomp
!
! Local variables
!
INTEGER :: i
REAL,DIMENSION(mnsz) :: mixed
!
!     + + + purpose + + +
!
!     this subroutine perfoms the actual mixing process.
!
!     + + + keywords + + +
!     mixing
!
!
!     + + + argument declarations + + +

!     + + + argument definitions + + +
!
!     cmass	- total mass of a component contained in a subregion
!     mass	- total mass in a subregion
!     nlay	- number of layers to be mixed
!     u		- mixing coefficient
!	    xcomp	- component value that is mixed

!     + + + local variables + + +
!
!
!     + + + local variable definitions + + +
!
!     i		- index for layers in a subregion
!	    mixed	- temperory variable containing the mixed component

!     + + + end specifications + + +

!     do the mixing process.
!
DO i = 1,nlay
  mixed(i) = (1-u)*xcomp(i) + (u*cmass/mass)
  xcomp(i) = mixed(i)
END DO
!
END SUBROUTINE mixproc

Project Documents/Source Code Original/Mixproc.f90


c
c-----------------------------------------------------------------------
c subroutine: wfta
c winograd fourier transform algorithm
c-----------------------------------------------------------------------
c
      subroutine wfta(xr,xi,n,invrs,init,ierr)
      dimension xr(1),xi(1)
c
c inputs:
c   n-- transform length.  must be formed as the product of
c       relatively prime integers from the set:
c           2,3,4,5,7,8,9,16
c       thus the largest possible value of n is 5040.
c   xr(.)-- array that holds the real part of the data
c           to be transformed.
c   xi(.)-- array that holds the imaginary part of the
c           data to be transformed.
c   invrs-- parameter that flags whether or not the inverse
c           transform is to be calculated.  a division by n
c           is included in the inverse.
c           invrs = 1 yields inverse transform
c           invrs .ne. 1 gives forward transform
c   init-- parameter that flags whether or not the program
c          is to be initialized for this value of n.  the
c          initialization is performed only once in order to
c          to speed up the computation on succeeding calls
c          to the wfta routine, when n is held fixed.
c          init = 0 results in initialization.
c   ierr-- error code that is negative when the wfta
c          terminates incorrectly.
c           0 = successful completion
c          -1 = this value of n does not factor properly
c          -2 = an initialization has not been done for
c               this value of n.
c
c
c   the following two cards may be changed if the maximum
c   desired transform length is less than 5040
c
c  *********************************************************************
      dimension sr(1782),si(1782),coef(1782)
      integer indx1(1008),indx2(1008)
c  *********************************************************************
c
      common na,nb,nc,nd,nd1,nd2,nd3,nd4
c
c   test for initial run
c
      if(init.eq.0) call inishl(n,coef,xr,xi,indx1,indx2,ierr)
c
      if(ierr.lt.0) return
      m=na*nb*nc*nd
      if(m.eq.n) go to 100
      ierr=-2
      return
c
c  error(-2)-- program not initialized for this value of n
c
100   nmult=nd1*nd2*nd3*nd4
c
c   the following code maps the data arrays xr and xi to
c   the working arrays sr and si via the mapping vector
c   indx1(.).  the permutation of the data follows the
c   sino correspondence of the chinese remainder theorem.
c
      j=1
      k=1
      inc1=nd1-na
      inc2=nd1*(nd2-nb)
      inc3=nd1*nd2*(nd3-nc)
      do 140 n4=1,nd
      do 130 n3=1,nc
      do 120 n2=1,nb
      do 110 n1=1,na
      ind=indx1(k)
      sr(j)=xr(ind)
      si(j)=xi(ind)
      k=k+1
110   j=j+1
120   j=j+inc1
130   j=j+inc2
140   j=j+inc3
c
c   do the pre-weave modules
c
      call weave1(sr,si)
c
c   the following loop performs all the multiplications of the
c   winograd fourier transform algorithm.  the multiplication
c   coefficients are stored on the initialization pass in the
c   array coef(.).
c
      do 200 j=1,nmult
      sr(j)=sr(j)*coef(j)
      si(j)=si(j)*coef(j)
  200  continue
c
c   do the post-weave modules
c
      call weave2(sr,si)
c
c
c   the following code maps the working arrays sr and si
c   to the data arrays xr and xi via the mapping vector
c   indx2(.).  the permutation of the data follows the
c   chinese remainder theorem.
c
      j=1
      k=1
      inc1=nd1-na
      inc2=nd1*(nd2-nb)
      inc3=nd1*nd2*(nd3-nc)
c
c   check for inverse
c
      if(invrs.eq.1) go to 400
      do 340 n4=1,nd
      do 330 n3=1,nc
      do 320 n2=1,nb
      do 310 n1=1,na
      kndx=indx2(k)
      xr(kndx)=sr(j)
      xi(kndx)=si(j)
      k=k+1
310   j=j+1
320   j=j+inc1
330   j=j+inc2
340   j=j+inc3
      return
c
c   different permutation for the inverse
c
400   fn=float(n)
      np2=n+2
      indx2(1)=n+1
      do 440 n4=1,nd
      do 430 n3=1,nc
      do 420 n2=1,nb
      do 410 n1=1,na
      kndx=np2-indx2(k)
      xr(kndx)=sr(j)/fn
      xi(kndx)=si(j)/fn
      k=k+1
410   j=j+1
420   j=j+inc1
430   j=j+inc2
440   j=j+inc3
      return
      end


      SUBROUTINE CALAVBOLD (ISTL_)
C
C *** OLD STANDARD
C
C **  SUBROUTINE CALAV CALCULATES VERTICAL VISCOSITY AND DIFFUSIVITY
C **  USING GLAPERIN ET AL'S MODIFICATION OF THE MELLOR-YAMADA MODEL
C **  (NOTE AV, AB, AND AQ ARE ACTUALLY DIVIDED BY H)
C **  IF ISGA=1 VALUES ARE GEOMETRIC AVERAGES WITH THE PREVIOUS VALUES
C CHANGE RECORD
C  ADDED DRYCELL BYPASS AND CONSISTENT INITIALIZATION OF DRY VALUES
C
      USE GLOBAL
	IMPLICIT NONE
	REAL::QQIMAX,RIQMIN,RIQMAX,RIQ
	REAL::SFAV,SFAB,ABTMP,AVTMP
	INTEGER::K,L,LS,ISTL_
C   SMTOP2   =      7.8464
C   SMBOT1   =     34.6764
C   SMBOT2   =      6.1272
C   RLIMIT   =      0.0233
C   SHMIN    =      0.0934
C   SMMIN    =      0.1099
C   SHMAX    =      5.2073
C   SMMAX    =      4.9639
C
      QQIMAX=1./QQMIN
      AVMAX=AVO
      ABMAX=ABO
      AVMIN=10.
      ABMIN=10.
      RIQMIN=-0.023
      RIQMAX=0.28
      DO K=1,KC
        DO L=1,LC
          IF(IMASKDRY(L).EQ.1)THEN
            AV(L,K)=AVO*HPI(L)
            AB(L,K)=ABO*HPI(L)
          ENDIF
        ENDDO
      ENDDO
      IF(ISFAVB.EQ.0)THEN
        DO K=1,KS
          DO L=2,LA
            IF(LMASKDRY(L))THEN
              QQI(L)=1./QQ(L,K)
              QQI(L)=MIN(QQI(L),QQIMAX)
            ENDIF
          ENDDO
          DO L=2,LA
            IF(LMASKDRY(L))THEN
              RIQ=-GP*HP(L)*DML(L,K)*DML(L,K)*DZIG(K)
     &            *(B(L,K+1)-B(L,K))*QQI(L)
              RIQ=MAX(RIQ,RIQMIN)
              RIQ=MIN(RIQ,RIQMAX)
C
C      SFAV=0.4*(1.+8.*RIQ)/((1.+36.*RIQ)*(1.+6.*RIQ))
C      SFAB=0.5/(1.+36.*RIQ)
C
              SFAV=0.3933*(1.+7.8464*RIQ)/((1.+34.6764*RIQ)*(1.+
     &            6.1272*RIQ))
              SFAB=0.4939/(1.+34.6764*RIQ)
             AB(L,K)=AVCON*SFAB*DML(L,K)*HP(L)*QQSQR(L,K)+ABO
             AV(L,K)=AVCON*SFAV*DML(L,K)*HP(L)*QQSQR(L,K)+AVO
              AVMAX=MAX(AVMAX,AV(L,K))
              ABMAX=MAX(ABMAX,AB(L,K))
              AVMIN=MIN(AVMIN,AV(L,K))
              ABMIN=MIN(ABMIN,AB(L,K))
              AV(L,K)=AV(L,K)*HPI(L)
              AB(L,K)=SCB(L)*AB(L,K)*HPI(L)
            ENDIF
          ENDDO
        ENDDO
      ENDIF
      IF(ISFAVB.EQ.1)THEN
        DO K=1,KS
          DO L=2,LA
            IF(LMASKDRY(L))THEN
              QQI(L)=1./QQ(L,K)
              QQI(L)=MIN(QQI(L),QQIMAX)
            ENDIF
          ENDDO
          DO L=2,LA
            IF(LMASKDRY(L))THEN
              RIQ=-GP*HP(L)*DML(L,K)*DML(L,K)*DZIG(K)
     &            *(B(L,K+1)-B(L,K))*QQI(L)
              RIQ=MAX(RIQ,RIQMIN)
              RIQ=MIN(RIQ,RIQMAX)
C
C      SFAV=0.4*(1.+8.*RIQ)/((1.+36.*RIQ)*(1.+6.*RIQ))
C      SFAB=0.5/(1.+36.*RIQ)
C
              SFAV=0.3933*(1.+7.8464*RIQ)/((1.+34.6764*RIQ)*(1.+
     &            6.1272*RIQ))
              SFAB=0.4939/(1.+34.6764*RIQ)
              ABTMP=AVCON*SFAB*DML(L,K)*HP(L)*QQSQR(L,K)+ABO
              AVTMP=AVCON*SFAV*DML(L,K)*HP(L)*QQSQR(L,K)+AVO
              AVMAX=MAX(AVMAX,AVTMP)
              ABMAX=MAX(ABMAX,ABTMP)
              AVMIN=MIN(AVMIN,AVTMP)
              ABMIN=MIN(ABMIN,ABTMP)
              AV(L,K)=0.5*(AV(L,K)+AVTMP*HPI(L))
              AB(L,K)=SCB(L)*0.5*(AB(L,K)+ABTMP*HPI(L))
            ENDIF
          ENDDO
        ENDDO
      ENDIF
      IF(ISFAVB.EQ.2)THEN
        DO K=1,KS
          DO L=2,LA
            IF(LMASKDRY(L))THEN
              QQI(L)=1./QQ(L,K)
              QQI(L)=MIN(QQI(L),QQIMAX)
            ENDIF
          ENDDO
          DO L=2,LA
            IF(LMASKDRY(L))THEN
              RIQ=-GP*HP(L)*DML(L,K)*DML(L,K)*DZIG(K)
     &            *(B(L,K+1)-B(L,K))*QQI(L)
              RIQ=MAX(RIQ,RIQMIN)
              RIQ=MIN(RIQ,RIQMAX)
C
C      SFAV=0.4*(1.+8.*RIQ)/((1.+36.*RIQ)*(1.+6.*RIQ))
C      SFAB=0.5/(1.+36.*RIQ)
C
              SFAV=0.3933*(1.+7.8464*RIQ)/((1.+34.6764*RIQ)*(1.+
     &            6.1272*RIQ))
              SFAB=0.4939/(1.+34.6764*RIQ)
              ABTMP=AVCON*SFAB*DML(L,K)*HP(L)*QQSQR(L,K)+ABO
              AVTMP=AVCON*SFAV*DML(L,K)*HP(L)*QQSQR(L,K)+AVO
              AVMAX=MAX(AVMAX,AVTMP)
              ABMAX=MAX(ABMAX,ABTMP)
              AVMIN=MIN(AVMIN,AVTMP)
              ABMIN=MIN(ABMIN,ABTMP)
              AV(L,K)=SQRT(AV(L,K)*AVTMP*HPI(L))
              AB(L,K)=SCB(L)*SQRT(AB(L,K)*ABTMP*HPI(L))
            ENDIF
          ENDDO
        ENDDO
      ENDIF
      ! *** NOW APPLY MAXIMUM, IF REQURIED
      IF(ISAVBMX.GE.1)THEN
        DO K=1,KS
          DO L=2,LA
            AVTMP=AVMX*HPI(L)
            ABTMP=ABMX*HPI(L)
            AV(L,K)=MIN(AV(L,K),AVTMP)
            AB(L,K)=MIN(AB(L,K),ABTMP)
          ENDDO
        ENDDO
      ENDIF
      DO K=1,KS
        DO L=2,LA
          LS=LSC(L)
          AVUI(L,K)=2./(AV(L,K)+AV(LWEST(L),K))
          AVVI(L,K)=2./(AV(L,K)+AV(LS,K))
        ENDDO
      ENDDO
      DO K=2,KS
        DO L=2,LA
          AQ(L,K)=0.205*(AV(L,K-1)+AV(L,K))
        ENDDO
      ENDDO
      DO L=2,LA
        AQ(L,1)=0.205*AV(L,1)
        AQ(L,KC)=0.205*AV(L,KS)
      ENDDO
      RETURN
      END


  !> @brief Standard kinds for numeric types
  !>
  !> This module provides the numeric kinds we think
  !> you might need, using names that match those in
  !> F2008. This makes it smooth to change to std F2008
  !> by simply removing this module.
  !>
  !> Do remember that not every length of type has to
  !> exist on a particular system - for those which
  !> don't you will get AT LEAST the requested length
  !> if this does not exceed the longest the system offers.

MODULE kinds

  IMPLICIT NONE

  !> Very short integer (8 bit, -128 to 127)
  INTEGER, PARAMETER :: INT8 = SELECTED_INT_KIND(2)
  !> Short integer (16 bit, -32 768 to 32 767)
  INTEGER, PARAMETER :: INT16 = SELECTED_INT_KIND(4)
  !> "Normal" integer (32 bit == 4 byte, -2 147 483 648 to 2 147 483 647)
  INTEGER, PARAMETER :: INT32 = SELECTED_INT_KIND(9)
  !> Long integer (64 bit), -9 223 372 036 854 775 808 to
  !> 9 223 372 036 854 775 807)
  INTEGER, PARAMETER :: INT64 = SELECTED_INT_KIND(15)

  !> Normal "float" (32 bit = 4 bytes, approx -3.4e38 to 3.4e38 and
  !> covering values down to about 1e-38 magnitude)
  INTEGER, PARAMETER :: REAL32 = SELECTED_REAL_KIND(6, 37)
  !> Longer "double" (64 bit, approx -1.8e308 to 1.8e308 and
  !> covering values down to about 2e-308 magnitude)
  INTEGER, PARAMETER :: REAL64 = SELECTED_REAL_KIND(15, 307)
  !> Extra long real (128 bit = 16 bytes). Few systems have numbers
  !> this long at all!
  INTEGER, PARAMETER :: REAL128 = SELECTED_REAL_KIND(33, 4931)

END MODULE


module ops_module

  abstract interface
    subroutine op(x, y, z)
      integer, intent(in) :: x, y
      integer, intent(out) :: z
    end subroutine
  end interface

contains

  subroutine foo(x, y, r1, r2)
    integer, intent(in) :: x, y
    integer, intent(out) :: r1, r2
    procedure (op) add1, add2
    procedure (op), pointer::p
    p=>add1
    call p(x, y, r1)
    p=>add2
    call p(x, y, r2)
  end subroutine
end module

subroutine add1(x, y, z)
  integer, intent(in) :: x, y
  integer, intent(out) :: z
  z = x + y
end subroutine

subroutine add2(x, y, z)
  integer, intent(in) :: x, y
  integer, intent(out) :: z
  z = x + 2 * y
end subroutine


subroutine findSpan(u, k, t, nctl, ind)

  !***DESCRIPTION
  !
  !     Written by Gaetan Kenway. Adapted from "The NURBS BooK" Algorithm A2.1
  !
  !     Abstract: Determine the knot span index

  !     Description of Arguments
  !     Input:
  !     u       - Real, parametric location we are looking for
  !     k       - Integer, order of B-spline
  !     t       - Real, size(nctl + k), knot vector
  !
  !     Ouput:
  !     ind     - Integer, knot span index

  use precision
  implicit none

  ! Input
  integer, intent(in)             :: k, nctl
  real(kind=realType), intent(in) :: u, t(nctl+k)
  ! Output
  integer, intent(out)            :: ind

  ! Working
  integer :: low, mid, high

  if (u >= t(nctl+1)) then
     ind = nctl
  else if (u < t(k)) then
     ind = k
  else
     low = k
     high = nctl+1

     ! Do a binary search
     mid = (low+high)/2
     do while ( (u < t(mid) .or. u >= t(mid+1)))
        if (u < t(mid)) then
           high = mid
        else
           low = mid
        end if

        mid = (low+high)/2
     end do

     ind = mid
  end if

end subroutine findSpan


! Fortran code to perform moelcular dynamics simulations
! Author: Anantha Rao
! Reg no:20181044

module param
    implicit none
    integer, parameter :: n_part=1000
    real*8, parameter:: T = 1.0d0, m=1.0d0, kbT=1.0d0
    real*8, parameter:: sigma = 1.0d0, eps = 4.0d0, rc = 2.5d0
    real*8, parameter:: tf=16.0d0, dt=0.005d0
    real*8, parameter:: lx=20.0d0, ly=20.0d0, lz=20.0d0
    real*8, parameter:: sigma6=sigma**6, sigma12=sigma**12, sigma2=sigma*sigma
    real*8, parameter:: fc=eps*((12.0d0*sigma12/(rc**13))-(6.0d0*sigma6/(rc**7)))
    real*8, parameter:: ufc = fc*rc+eps*(((sigma/rc)**12)-(sigma/rc)**6)
    real*8, parameter:: lxby2=lx/2.0d0, lyby2=ly/2.0d0, lzby2=lz/2.0d0
    real*8 :: vx(n_part), vy(n_part), vz(n_part)
    real*8 :: x(n_part), y(n_part), z(n_part)
    real*8 :: xp(n_part), yp(n_part), zp(n_part)
    real*8 :: fx(n_part), fy(n_part), fz(n_part)
    real*8 :: xnew(n_part), ynew(n_part), znew(n_part)
    real*8 :: xx(n_part), yy(n_part), zz(n_part)
    real*8 :: dx, dy, dz, dr
    real*8 :: avg_vx,avg_vy, avg_vz, sumv2, vxbar, vybar, vzbar
    real*8 :: randm, fs, force, ke, pe, te, lj, ljforces, theoryke, scalef
    real*8 :: x1, x2, y1, y2, z1, z2, tt
    integer :: i,j,k
end module param

program md_verlet
    use param
    implicit none
    open (12, file='cubic.txt', action='read')
    open(13, file='data.dat', action='write')
    open(14, file='momt.dat', action='write')
    do i = 1, n_part
        read(12,*) x(i), y(i), z(i)
    end do
    write(*,*) n_part, "Particle Positions Initialized"
    call vel_init
    call calcforces
    write(*,*) n_part, "Particle Velocities Initialized"
    write(*,*) "Potential Energy", pe/dfloat(n_part)
    write(*,*) "Kinetic Energy", ke/dfloat(n_part)

    do i = 1, n_part
        xp(i) = x(i)-vx(i)*dt
        yp(i) = y(i)-vy(i)*dt
        zp(i) = z(i)-vz(i)*dt
    end do

    tt=0.0d0
    do while (tt<= tf)
        call calcforces
        call integrate
        write(13,*)tt, ke/dfloat(n_part), pe/dfloat(n_part), (ke+pe)/dfloat(n_part)
        write(14,*) tt, avg_vx, avg_vy, avg_vz
        write(*,*) tt, avg_vx, avg_vy, avg_vz
        tt=tt+dt
    end do
    close(12)
    close(13)
    close(14)
end program md_verlet
subroutine vel_init
    use param
    implicit none
    avg_vx = 0.0d0; avg_vy=0.0d0; avg_vz=0.0d0
    sumv2=0.0d0
    ke=0.0d0
    do i = 1, n_part
        call random_number(randm); vx(i) = (randm-0.5d0)
        call random_number(randm); vy(i) = (randm-0.5d0)
        call random_number(randm); vz(i) = (randm-0.5d0)
    end do

    do i = 1, n_part
        avg_vx=avg_vx+vx(i)
        avg_vy=avg_vy+vy(i)
        avg_vz=avg_vz+vz(i)
    end do

    avg_vx=avg_vx/dfloat(n_part)
    avg_vy=avg_vy/dfloat(n_part)
    avg_vz=avg_vz/dfloat(n_part)

    vxbar = 0.0d0
    vybar = 0.0d0
    vzbar = 0.0d0

    do i = 1, n_part
        vx(i) = (avg_vx-vx(i))
        vy(i) = (avg_vy-vy(i))
        vz(i) = (avg_vz-vz(i))
    end do

    do i = 1, n_part
        vxbar=vxbar+vx(i)
        vybar=vybar+vy(i)
        vzbar=vzbar+vz(i)
    end do

    do i = 1, n_part
        sumv2=sumv2+(vx(i)*vx(i)+vy(i)*vy(i)+vz(i)*vz(i))
    end do

    vxbar=vxbar/dfloat(n_part)
    vybar=vybar/dfloat(n_part)
    vzbar=vzbar/dfloat(n_part)
    fs = dsqrt((3.0d0*T*(n_part-1.0d0))/sumv2)
    do i = 1, n_part
        vx(i) = vx(i)*fs
        vy(i) = vy(i)*fs
        vz(i) = vz(i)*fs
        ke=ke+(vx(i)*vx(i)+vy(i)*vy(i)+vz(i)*vz(i))
    end do
    ke = ke*0.5d0

end subroutine vel_init

subroutine calcforces
    use param
    implicit none
    pe = 0.0d0
    do i = 1, n_part
        fx(i) = 0.0d0; fy(i) = 0.0d0; fz(i) = 0.0d0
    end do

    do i = 1, n_part-1
        x1=x(i); y1=y(i); z1=z(i)
        do j = i+1, n_part
            x2=x(j); y2=y(j); z2=z(j)
            dx = x1-x2; dy = y1-y2; dz=z1-z2
            if(abs(dx).ge.lxby2) dx=(lx-abs(dx))*((-1.0d0*dx/abs(dx)))
            if(abs(dy).ge.lyby2) dy=(ly-abs(dy))*((-1.0d0*dy/abs(dy)))
            if(abs(dz).ge.lzby2) dz=(lz-abs(dz))*((-1.0d0*dz/abs(dz)))

            dr = dsqrt(dx*dx+dy*dy+dz*dz)
            if (dr <= rc) then
                lj = eps*((sigma/dr)**12-(sigma/dr)**6)-ufc+fc*dr
                pe = pe + lj
                ljforces = eps*((12.0d0*((sigma12)/(dr)**13))-(6.0d0*((sigma6/(dr)**7))))-fc
                fx(i) = fx(i) + ljforces*(dx/dr)
                fy(i) = fy(i) + ljforces*(dy/dr)
                fz(i) = fz(i) + ljforces*(dz/dr)
                fx(j) = fx(j) - ljforces*(dx/dr)
                fy(j) = fy(j) - ljforces*(dy/dr)
                fz(j) = fz(j) - ljforces*(dz/dr)

            end if
        end do
    end do
end subroutine calcforces

subroutine integrate
    use param
    implicit none
    real*8::dt2
    dt2=dt**2
    avg_vx=0.0d0; avg_vy=0.0d0; avg_vz=0.0d0; ke=0.0d0
    do i = 1, n_part
        xnew(i) = 2.0d0*x(i)-xp(i)+fx(i)*dt2
        ynew(i) = 2.0d0*y(i)-yp(i)+fy(i)*dt2
        znew(i) = 2.0d0*z(i)-zp(i)+fz(i)*dt2
        vx(i) = (xnew(i)-xp(i))/(2.0d0*dt)
        vy(i) = (ynew(i)-yp(i))/(2.0d0*dt)
        vz(i) = (znew(i)-zp(i))/(2.0d0*dt)
        ke = ke + 0.5d0*(vx(i)*vx(i)+vy(i)*vy(i)+vz(i)*vz(i))
        avg_vx=avg_vx+(vx(i)/dfloat(n_part))
        avg_vy=avg_vy+(vy(i)/dfloat(n_part))
        avg_vz=avg_vz+(vz(i)/dfloat(n_part))

    end do

    !if (mod(int(tt/0.005d0),100)==0) then
    !    theoryke=1.50d0*dfloat(n_part)*kbT
    !    scalef=dsqrt(theoryke/ke)
    !    vx=vx*scalef
    !    vy=vy*scalef
    !    vz=vz*scalef
    !    ke=0.0d0
    !    do i=1,n_part
    !        ke=ke+0.50d0*(vx(i)*vx(i)+vy(i)*vy(i)+vz(i)*vz(i))
    !    end do
    !endif

    do i = 1, n_part
        xnew(i) = xp(i) + 2.0d0*vx(i)*dt
        ynew(i) = yp(i) + 2.0d0*vy(i)*dt
        znew(i) = zp(i) + 2.0d0*vz(i)*dt
        xp(i)=x(i)
        yp(i)=y(i)
        zp(i)=z(i)

        x(i) = xnew(i)
        y(i) = ynew(i)
        z(i) = znew(i)

        if (x(i)>lx) then
            x(i) = x(i)-lx
            xp(i) = xp(i)-lx
        elseif(x(i)<0.0d0) then
            x(i) = x(i)+lx
            xp(i) = xp(i)+lx
        end if
        if (y(i)>ly) then
            y(i) = y(i)-ly
            yp(i) = yp(i)-ly
        elseif(z(i)<0.0d0) then
            z(i) = z(i)+lz
            zp(i) = zp(i)+lz
        end if
        if (z(i)>lz) then
            z(i) = z(i)-lz
            zp(i) = zp(i)-lz
        elseif(x(i)<0.0d0) then
            z(i) = z(i)+lz
            zp(i) = zp(i)+lz
        end if
    end do
end subroutine integrate


!******************************************************************************
!*
!*                              Chi2 Fitting Module
!*
!******************************************************************************

MODULE ext_chi2

  USE utilities, ONLY: DP
  USE core, ONLY: parinfo_type, indpar_type, Qabs_type
  IMPLICIT NONE
  PRIVATE

  INTEGER, SAVE, PUBLIC :: Nx, Ny, NwOBS, xOBS, yOBS, jw
  INTEGER, DIMENSION(:), ALLOCATABLE, SAVE, PUBLIC :: iwfree
  REAL(DP), DIMENSION(:), ALLOCATABLE, SAVE, PUBLIC :: wOBS, nuOBS
  REAL(DP), DIMENSION(:), ALLOCATABLE, SAVE, PUBLIC :: Fnu_mod, resid
  REAL(DP), DIMENSION(:,:), ALLOCATABLE, SAVE, PUBLIC :: extinct
  REAL(DP), DIMENSION(:,:,:), ALLOCATABLE, SAVE, PUBLIC :: FnuOBS, dFnuOBS
  REAL(DP), DIMENSION(:,:,:,:), ALLOCATABLE, SAVE, PUBLIC :: invLcovarOBS
  LOGICAL, SAVE, PUBLIC :: iid ! indpdt identically dist. (wvl)
  LOGICAL, DIMENSION(:,:,:), ALLOCATABLE, SAVE, PUBLIC :: mask, maskpar

  !! Init param
  !!------------
  TYPE(indpar_type), SAVE, PUBLIC :: ind
  TYPE(parinfo_type), DIMENSION(:), ALLOCATABLE, SAVE, PUBLIC :: parinfo
  TYPE(Qabs_type), DIMENSION(:), ALLOCATABLE, SAVE, PUBLIC :: Qabs

  PUBLIC :: residuals

CONTAINS

  !! Main function for L-M
  !!-----------------------
  FUNCTION residuals(par, NwOBS0)

    USE utilities, ONLY: DP
    USE core, ONLY: specModel
    IMPLICIT NONE

    INTEGER, INTENT(IN) :: NwOBS0
    REAL(DP), DIMENSION(:), INTENT(IN) :: par
    INTEGER :: i

    REAL(DP), DIMENSION(NwOBS0) :: residuals

    Fnu_mod(:) = specModel(wOBS(:), INDPAR=ind, PARVAL=par(:), &
                           MASK=mask(xOBS,yOBS,:), &
                           QABS=Qabs(:), EXTINCT=extinct(:,:))

    !! Unweighted residuals
    WHERE (mask(xOBS,yOBS,:))
      resid(:) = FnuOBS(xOBS,yOBS,:) - Fnu_mod(:)
    ELSEWHERE
      resid(:) = 0._DP
    END WHERE

    !! Weighted residuals
    ! residuals(:) = MATMUL(invLcovarOBS(xOBS,yOBS,:,:), resid(:))

    !! With keyword iid
    IF (iid) THEN
      FORALL (i=1:NwOBS0) &
        residuals(i) = invLcovarOBS(xOBS,yOBS,i,i) * resid(i)
    ELSE
      residuals(:) = MATMUL(invLcovarOBS(xOBS,yOBS,:,:), resid(:))
    END IF

  END FUNCTION residuals

END MODULE ext_chi2


c
c
c
c     =====================================================
       subroutine qinit(maxmx,maxmy,meqn,mbc,mx,my,xlower,ylower,
     &                   dx,dy,q)
c     =====================================================
c
c     # Set initial conditions for q.
c     # A square region where q=1 together with a cone
c
       implicit double precision (a-h,o-z)
       dimension q(1-mbc:maxmx+mbc, 1-mbc:maxmy+mbc, meqn)
c
       do 20 i=1,mx
	  xi = xlower + (i-0.5d0)*dx
          do 20 j=1,my
	     yj = ylower + (j-0.5d0)*dy
 	     if (xi.lt.0.6d0 .and. xi.gt.0.1d0 .and. yj.gt.-0.25d0 .and.
     &		 yj.lt.0.25d0) then
		     q(i,j,1) = 1.d0
		   else
		     q(i,j,1) = 0.d0
		   endif
	     r = dsqrt((xi+0.45d0)**2 + yj**2)
	     if (r .lt. 0.35d0) then
	         q(i,j,1) = 1.d0 - r/0.35d0
		 endif

  20         continue
       return
       end


module globals

  !
  ! This code uses atomic units in all calculations.  These are not
  ! always the way you want to quote them, so the conversions are:
  !
  ! Time:        1 a.u. = 2.41888E-17 s
  ! Energy:      1 a.u. = 27.2114 eV
  ! Distance:    1 a.u. = 5.29177E-11 m
  ! Momentum:    1 a.u. = 1.99285E-24 kg m/s
  ! Magnetism:   1 a.u. = 2.35050E+5 T
  !

  use precision

  public

  !
  ! Define some global parameters
  !

  integer(idp), parameter :: dim = 2, potdata = 99, potlog = 98,&
       & chebwfn = 97, inputfile=96, chkptfile=95, maxpotcomps = 50,&
       & maxstringlength = 256, fftfor = -1, fftbac = 1,&
       & maxfilenamelen = 256, numcharlen = 6

  real(fdp), parameter :: pi =&
       & 3.141592653589793238462643383279502884197, cutoff = 1.0d-14,&
       & boltzk = 1.380658d-23, h = 6.6260755d-34, hbar = h/2.0d0/pi,&
       & masse = 9.1093898d-31, nm = 1.0d-9, chargee = 1.60217733d-19&
       & , eV = chargee, aut = 2.41888d-17, aue = 27.2114*eV, aus =&
       & 5.29177d-11, aup = 1.99285d-24, aub = 2.35050d5, c =&
       & 2.99792458d8, mu0 = 4.0d0*pi*1.0d-7

  complex(cdp), parameter :: ii = (0.0d0, 1.0d0)

  real(fdp), dimension(15), parameter :: constantvalues = (/ pi, c,&
       & masse , ev, nm, chargee, h, hbar, boltzk, mu0, aut, aue, aus&
       &, aup, aub /)

  character(LEN = *), parameter :: constants =&
       & 'pi c masse ev nm chargee h hbar boltzk mu0 aut aue aus aup&
       & aub'

  !
  ! Define the type and default values for all the user-defineable
  ! global variables
  !

  type params

     character(LEN = 50) :: datadir = 'data/', chkpntfile = 'chkpt.',&
          & basename = 'wavefn.', optimisation = 'none' ,&
          & potsmoothtype = 'none', initialwavefn = 'gaussian', gauge&
          & = '(-y,x,0)'

     real(fdp) :: mass = 6.67d-2*masse, fermienergy = 0.0d0,&
          & temperature = 0.01d0, initialenergy = 0.0d0, t = 0.0d0,&
          & distance = 1.0d4*aus, tstep = 0.0d0, speccutoff = 0.01d0,&
          & externale = 0.0d0, externalb = 0.0d0, omegal = 0.0d0,&
          & eigenfactor = 1.25d0

     real(fdp), dimension(dim) :: p = 0.0d0, pspread = 0.05d0, pmax =&
          & 0.0d0, accuracyfactor = 1.0d0, position = 0.0d0,&
          & wavefnwidth = 0.0d0, gridspacing = 0.0d0, pspacing =&
          & 0.0d0, spacesize = 2.0d4*aus, maxgridspacing = 0.0d0

     real(fdp), dimension(2) :: potrange = 0.0d0

     integer(idp), dimension(dim) :: n = 0, extraboundary = 2, smooth&
          & = 32, plotpointnum = 0

     integer(idp) :: timesteps = 1, plotnumber = 0, chkpntfreq = 1

     logical, dimension(maxpotcomps) :: potcomps = .false.

     logical, dimension(2*dim) :: comppotpos = .true.

     real(fdp), dimension(4) :: potbound = 0.0d0

     logical :: plotwfn = .true., plotwfnp = .true., plotpot = .true.&
          & , tranrefl = .true., plotcomplex = .true., espectrum =&
          & .true., pspectrum = .true., tspectrum = .true.,&
          & conductance = .true. , primefactorn = .true.

  end type params

  type def_params

     !
     ! Defines parameters which are avalaible for all routines
     !

     logical :: datadir = .false., chkpntfile = .false., basename = .false., optimisation = .false.,&
          & potsmoothtype = .false., initialwavefn = .false., mass =&
          & .false., fermienergy = .false., temperature = .false.,&
          & initialenergy = .false., t = .false., distance = .false.,&
          & tstep = .false., speccutoff = .false., p = .false.,&
          & pspread = .false., pmax = .false., accuracyfactor =&
          & .false., position = .false., wavefnwidth = .false.,&
          & gridspacing = .false., pspacing = .false., spacesize =&
          & .false., potrange = .false., n = .false., extraboundary =&
          & .false., plotpointnum = .false., timesteps = .false., chkpntfreq = .false.,&
          & smooth = .false., plotnumber = .false., potcomps =&
          & .false., comppotpos = .false., potbound = .false.,&
          & plotwfn = .false., plotwfnp = .false., plotpot = .false.,&
          & tranrefl = .false., plotcomplex = .false., espectrum =&
          & .false., pspectrum = .false., tspectrum = .false.,&
          & conductance = .false., externale = .false., externalb =&
          & .false., potential = .false., primefactorn = .false.,&
          & omegal = .false., gauge = .false., eigenfactor = .false.,&
          & maxgridspacing = .false.

  end type def_params

  type(params) :: parameters
  type(def_params) :: defined_parameters

end module globals


! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
! See https://llvm.org/LICENSE.txt for license information.
! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
!
! test for comparison operation take quad precision

program test
  integer, parameter :: n = 2
  logical :: r1 = 1.1_16 > 1.2_16
  logical :: r2
  integer :: result(n), expect(n)
  expect = 1
  result = 0

  r2 = 621424.2346523454241479464_16 <= 621424.234652345424147954_16
  if (r1 .eq. .false.) result(1) = 1
  if (r2 .eq. .true.) result(2) = 1
  call check(result, expect, n)

end program