!-------------------------------------------------------------------------------
! Copyright (c) 2016 The University of Tokyo
! This software is released under the MIT License, see LICENSE.txt
!-------------------------------------------------------------------------------
!>  This module contains subroutines used in 3d eigen analysis for
!!   elements 342, 352, 362
module m_eigen_LIB_3d2mass

contains
  !----------------------------------------------------------------------*
  subroutine MASS_C3D20(XX,YY,ZZ,EE,PP,RHO,SS,fstrEIG)
    !----------------------------------------------------------------------*
    !
    ! CALCULATION 3D 20-NODE SOLID ELEMENT
    !
    use hecmw
    use m_fstr
    use gauss_integration
    implicit none
    ! I/F VARIABLES
    real(kind=kreal) :: XX(*), YY(*), ZZ(*), SS(*), EE, PP, RHO
    ! LOCAL VARIABLES
    integer(kind=kint), parameter :: NN = 20, NDOF = 3, ISIZE = (NN*NDOF)*(NN*NDOF + 1)/2
    integer(kind=kint), parameter :: NG = 3
    !parameter(NN=20, NDOF=3, ISIZE=(NN*NDOF)*(NN*NDOF + 1)/2, NG=3)
    real(kind=kreal)   :: D(6, 6), B(6, NDOF*NN), DB(6, NDOF*NN)
    real(kind=kreal)   :: H(NN), HR(NN), HS(NN), HT(NN)
    real(kind=kreal)   :: RI, SI, TI, RP, SP, TP, RM, SM, TM
    real(kind=kreal)   :: XJ11, XJ21, XJ31, XJ12, XJ22, XJ32, XJ13, XJ23, XJ33, DET, WG, DUM
    real(kind=kreal)   :: XJI11, XJI21, XJI31, XJI12, XJI22, XJI32, XJI13, XJI23, XJI33
    integer(kind=kint) :: I, J, L, LX, LY, LZ, NUM, J2
    real(kind=kreal)   :: DNDX, DNDY, DNDZ
    !*EHM CONSISTENT MASS MATRIX 18Apr2004
    real(kind=kreal)   :: totdiag, totmass
    integer(kind=kint) :: ind1, ind2
    type(fstr_eigen)   :: fstrEIG

    totdiag = 0.0
    totmass = 0.0
    ! ZERO CLEAR MATRIX S()
    do I=1,ISIZE
      SS(I)=0.0
    enddo
    ! LOOP FOR INTEGRATION POINTS
    do LX=1,NG
      RI=XG(NG,LX)
      do LY=1,NG
        SI=XG(NG,LY)
        do LZ=1,NG
          TI=XG(NG,LZ)
          RP=1.0+RI
          SP=1.0+SI
          TP=1.0+TI
          RM=1.0-RI
          SM=1.0-SI
          TM=1.0-TI
          !  INTERPOLATION FUNCTION
          H(1)=-0.125*RM*SM*TM*(2.0+RI+SI+TI)
          H(2)=-0.125*RP*SM*TM*(2.0-RI+SI+TI)
          H(3)=-0.125*RP*SP*TM*(2.0-RI-SI+TI)
          H(4)=-0.125*RM*SP*TM*(2.0+RI-SI+TI)
          H(5)=-0.125*RM*SM*TP*(2.0+RI+SI-TI)
          H(6)=-0.125*RP*SM*TP*(2.0-RI+SI-TI)
          H(7)=-0.125*RP*SP*TP*(2.0-RI-SI-TI)
          H(8)=-0.125*RM*SP*TP*(2.0+RI-SI-TI)
          H(9)=0.25*(1.0-RI**2)*SM*TM
          H(10)=0.25*RP*(1.0-SI**2)*TM
          H(11)=0.25*(1.0-RI**2)*SP*TM
          H(12)=0.25*RM*(1.0-SI**2)*TM
          H(13)=0.25*(1.0-RI**2)*SM*TP
          H(14)=0.25*RP*(1.0-SI**2)*TP
          H(15)=0.25*(1.0-RI**2)*SP*TP
          H(16)=0.25*RM*(1.0-SI**2)*TP
          H(17)=0.25*RM*SM*(1.0-TI**2)
          H(18)=0.25*RP*SM*(1.0-TI**2)
          H(19)=0.25*RP*SP*(1.0-TI**2)
          H(20)=0.25*RM*SP*(1.0-TI**2)
          !  DERIVATIVE OF INTERPOLATION FUNCTION
          !  FOR R-COORDINATE
          HR(1)=-0.125*RM*SM*TM+0.125*SM*TM*(2.0+RI+SI+TI)
          HR(2)=+0.125*RP*SM*TM-0.125*SM*TM*(2.0-RI+SI+TI)
          HR(3)=+0.125*RP*SP*TM-0.125*SP*TM*(2.0-RI-SI+TI)
          HR(4)=-0.125*RM*SP*TM+0.125*SP*TM*(2.0+RI-SI+TI)
          HR(5)=-0.125*RM*SM*TP+0.125*SM*TP*(2.0+RI+SI-TI)
          HR(6)=+0.125*RP*SM*TP-0.125*SM*TP*(2.0-RI+SI-TI)
          HR(7)=+0.125*RP*SP*TP-0.125*SP*TP*(2.0-RI-SI-TI)
          HR(8)=-0.125*RM*SP*TP+0.125*SP*TP*(2.0+RI-SI-TI)
          HR(9 )=-0.50*RI*SM*TM
          HR(10)=+0.25*(1.0-SI**2)*TM
          HR(11)=-0.50*RI*SP*TM
          HR(12)=-0.25*(1.0-SI**2)*TM
          HR(13)=-0.50*RI*SM*TP
          HR(14)=+0.25*(1.0-SI**2)*TP
          HR(15)=-0.50*RI*SP*TP
          HR(16)=-0.25*(1.0-SI**2)*TP
          HR(17)=-0.25*SM*(1.0-TI**2)
          HR(18)=+0.25*SM*(1.0-TI**2)
          HR(19)=+0.25*SP*(1.0-TI**2)
          HR(20)=-0.25*SP*(1.0-TI**2)
          !  FOR S-COORDINATE
          HS(1)=-0.125*RM*SM*TM+0.125*RM*TM*(2.0+RI+SI+TI)
          HS(2)=-0.125*RP*SM*TM+0.125*RP*TM*(2.0-RI+SI+TI)
          HS(3)=+0.125*RP*SP*TM-0.125*RP*TM*(2.0-RI-SI+TI)
          HS(4)=+0.125*RM*SP*TM-0.125*RM*TM*(2.0+RI-SI+TI)
          HS(5)=-0.125*RM*SM*TP+0.125*RM*TP*(2.0+RI+SI-TI)
          HS(6)=-0.125*RP*SM*TP+0.125*RP*TP*(2.0-RI+SI-TI)
          HS(7)=+0.125*RP*SP*TP-0.125*RP*TP*(2.0-RI-SI-TI)
          HS(8)=+0.125*RM*SP*TP-0.125*RM*TP*(2.0+RI-SI-TI)
          HS(9)=-0.25*(1.0-RI**2)*TM
          HS(10)=-0.50*RP*SI*TM
          HS(11)=+0.25*(1.0-RI**2)*TM
          HS(12)=-0.50*RM*SI*TM
          HS(13)=-0.25*(1.0-RI**2)*TP
          HS(14)=-0.50*RP*SI*TP
          HS(15)=+0.25*(1.0-RI**2)*TP
          HS(16)=-0.50*RM*SI*TP
          HS(17)=-0.25*RM*(1.0-TI**2)
          HS(18)=-0.25*RP*(1.0-TI**2)
          HS(19)=+0.25*RP*(1.0-TI**2)
          HS(20)=+0.25*RM*(1.0-TI**2)
          !  FOR T-COORDINATE
          HT(1)=-0.125*RM*SM*TM+0.125*RM*SM*(2.0+RI+SI+TI)
          HT(2)=-0.125*RP*SM*TM+0.125*RP*SM*(2.0-RI+SI+TI)
          HT(3)=-0.125*RP*SP*TM+0.125*RP*SP*(2.0-RI-SI+TI)
          HT(4)=-0.125*RM*SP*TM+0.125*RM*SP*(2.0+RI-SI+TI)
          HT(5)=+0.125*RM*SM*TP-0.125*RM*SM*(2.0+RI+SI-TI)
          HT(6)=+0.125*RP*SM*TP-0.125*RP*SM*(2.0-RI+SI-TI)
          HT(7)=+0.125*RP*SP*TP-0.125*RP*SP*(2.0-RI-SI-TI)
          HT(8)=+0.125*RM*SP*TP-0.125*RM*SP*(2.0+RI-SI-TI)
          HT(9)=-0.25*(1.0-RI**2)*SM
          HT(10)=-0.25*RP*(1.0-SI**2)
          HT(11)=-0.25*(1.0-RI**2)*SP
          HT(12)=-0.25*RM*(1.0-SI**2)
          HT(13)=0.25*(1.0-RI**2)*SM
          HT(14)=0.25*RP*(1.0-SI**2)
          HT(15)=0.25*(1.0-RI**2)*SP
          HT(16)=0.25*RM*(1.0-SI**2)
          HT(17)=-0.5*RM*SM*TI
          HT(18)=-0.5*RP*SM*TI
          HT(19)=-0.5*RP*SP*TI
          HT(20)=-0.5*RM*SP*TI
          !  JACOBI MATRIX
          XJ11=0.0
          XJ21=0.0
          XJ31=0.0
          XJ12=0.0
          XJ22=0.0
          XJ32=0.0
          XJ13=0.0
          XJ23=0.0
          XJ33=0.0
          do I=1,NN
            XJ11=XJ11+HR(I)*XX(I)
            XJ21=XJ21+HS(I)*XX(I)
            XJ31=XJ31+HT(I)*XX(I)
            XJ12=XJ12+HR(I)*YY(I)
            XJ22=XJ22+HS(I)*YY(I)
            XJ32=XJ32+HT(I)*YY(I)
            XJ13=XJ13+HR(I)*ZZ(I)
            XJ23=XJ23+HS(I)*ZZ(I)
            XJ33=XJ33+HT(I)*ZZ(I)
          enddo
          !DETERMINANT OF JACOBIAN
          DET=XJ11*XJ22*XJ33 &
            +XJ12*XJ23*XJ31  &
            +XJ13*XJ21*XJ32  &
            -XJ13*XJ22*XJ31  &
            -XJ12*XJ21*XJ33  &
            -XJ11*XJ23*XJ32
          ! INVERSION OF JACOBIAN
          DUM=1.0/DET
          XJI11=DUM*( XJ22*XJ33-XJ23*XJ32)
          XJI21=DUM*(-XJ21*XJ33+XJ23*XJ31)
          XJI31=DUM*( XJ21*XJ32-XJ22*XJ31)
          XJI12=DUM*(-XJ12*XJ33+XJ13*XJ32)
          XJI22=DUM*( XJ11*XJ33-XJ13*XJ31)
          XJI32=DUM*(-XJ11*XJ32+XJ12*XJ31)
          XJI13=DUM*( XJ12*XJ23-XJ13*XJ22)
          XJI23=DUM*(-XJ11*XJ23+XJ13*XJ21)
          XJI33=DUM*( XJ11*XJ22-XJ12*XJ21)
          !  WEIGHT VALUE AT GAUSSIAN POINT
          WG=WGT(NG,LX)*WGT(NG,LY)*WGT(NG,LZ)*DET

          ind1 = 1
          do J=1,NN*NDOF
            ind2 = 1
            do J2=1,J
              NUM=(J-1)*J/2+J2
              !DEBUG
              !               IF(fstrEIG%mastyp.EQ.2) THEN
              !                IF(MOD(j,NDOF).EQ.MOD(j2,NDOF)) THEN
              !                  SS(NUM)=SS(NUM)+H(ind1)*H(ind2)*WG*RHO
              !                ENDIF
              !               ELSE IF(fstrEIG%mastyp.EQ.1) THEN
              if(j.EQ.j2) then
                SS(NUM)=SS(NUM)+H(ind1)*H(ind2)*WG*RHO
                totdiag=totdiag+H(ind1)*H(ind2)*WG*RHO
              endif
              if(mod(j2,ndof).EQ.mod(j,ndof)) then
                totmass=totmass+H(ind1)*H(ind2)*WG*RHO
              endif
              !               ENDIF
              if(mod(j2,NDOF).EQ.0) ind2 = ind2 + 1
            enddo
            if(mod(j,NDOF).EQ.0) ind1 = ind1 + 1
          enddo
        enddo
      enddo
    enddo
    !DEBUG
    !      IF(fstrEIG%mastyp.EQ.1) THEN
    do j = 1,nn*ndof
      num = j*(j+1)/2
      ss(num) = ss(num)*(2*totmass-totdiag)/(totdiag)
    end do
    if(2*totmass-totdiag .LT. 0) stop "Mass error 362!"
    !      ENDIF
    return
  end subroutine MASS_C3D20
  !----------------------------------------------------------------------*
  subroutine MASS_C3D15(XX,YY,ZZ,EE,PP,RHO,SS,fstrEIG)
    !----------------------------------------------------------------------*
    !
    ! CALCULATION 3D 15-NODE SOLID ELEMENT
    !
    use hecmw
    use m_fstr
    use gauss_integration
    implicit none
    ! I/F VARIABLES
    real(kind=kreal) :: XX(*), YY(*), ZZ(*), SS(*), EE, PP, RHO
    ! LOCAL VARIABLES
    integer(kind=kint), parameter :: NN = 15, NDOF = 3, ISIZE = (NN*NDOF)*(NN*NDOF + 1)/2
    integer(kind=kint), parameter :: NG = 3
    !parameter(NN=15, NDOF=3, ISIZE=(NN*NDOF)*(NN*NDOF + 1)/2, NG=3)
    real(kind=kreal)   :: D(6, 6), B(6, NDOF*NN), DB(6, NDOF*NN)
    real(kind=kreal)   :: H(NN), HL1(NN), HL2(NN), HL3(NN), HZ(NN)
    real(kind=kreal)   :: XJ11, XJ21, XJ31, XJ12, XJ22, XJ32, XJ13, XJ23, XJ33, DET, WG, DUM
    real(kind=kreal)   :: XJI11, XJI21, XJI31, XJI12, XJI22, XJI32, XJI13, XJI23, XJI33
    integer(kind=kint) :: I, J, L, L1, L2, LZ, NUM, J2
    real(kind=kreal)   :: X1, X2, X3, XL1, XL2, ZI
    real(kind=kreal)   :: DNDX, DNDY, DNDZ
    !*EHM CONSISTENT MASS MATRIX 18 Apr 2004
    real(kind=kreal)   :: totdiag, totmass
    integer(kind=kint) :: ind1, ind2
    type(fstr_eigen)   :: fstrEIG

    totdiag = 0.0
    totmass = 0.0
    ! ZERO CLEAR MATRIX S()
    do I=1,ISIZE
      SS(I)=0.0
    enddo
    ! LOOP FOR INTEGRATION POINTS
    do LZ=1,NG
      ZI=XG(NG,LZ)
      do L2=1,NG
        XL2=XG(NG,L2)
        X2 =(XL2+1.0)*0.5
        do L1=1,NG
          XL1=XG(NG,L1)
          X1=0.5*(1.0-X2)*(XL1+1.0)
          !  INTERPOLATION FUNCTION
          X3=1.0-X1-X2
          H(1)= 0.5*X1*(2.0*X1-2.-ZI)*(1.0-ZI)
          H(2)= 0.5*X2*(2.0*X2-2.-ZI)*(1.0-ZI)
          H(3)= 0.5*X3*(2.0*X3-2.-ZI)*(1.0-ZI)
          H(4)= 0.5*X1*(2.0*X1-2.+ZI)*(1.0+ZI)
          H(5)= 0.5*X2*(2.0*X2-2.+ZI)*(1.0+ZI)
          H(6)= 0.5*X3*(2.0*X3-2.+ZI)*(1.0+ZI)
          H(7)= 2.0*X1*X2*(1.0-ZI)
          H(8)= 2.0*X2*X3*(1.0-ZI)
          H(9)= 2.0*X1*X3*(1.0-ZI)
          H(10)=2.0*X1*X2*(1.0+ZI)
          H(11)=2.0*X2*X3*(1.0+ZI)
          H(12)=2.0*X1*X3*(1.0+ZI)
          H(13)=X1*(1.0-ZI**2)
          H(14)=X2*(1.0-ZI**2)
          H(15)=X3*(1.0-ZI**2)
          !  DERIVATIVE OF INTERPOLATION FUNCTION
          !  FOR L1-COORDINATE
          HL1(1)= 0.5*(4.0*X1-2.-ZI)*(1.0-ZI)
          HL1(2)= 0.0
          HL1(3)= 0.0
          HL1(4)= 0.5*(4.0*X1-2.+ZI)*(1.0+ZI)
          HL1(5)= 0.0
          HL1(6)= 0.0
          HL1(7)= 2.0*X2*(1.0-ZI)
          HL1(8)= 0.0
          HL1(9)= 2.0*X3*(1.0-ZI)
          HL1(10)=2.0*X2*(1.0+ZI)
          HL1(11)=0.0
          HL1(12)=2.0*X3*(1.0+ZI)
          HL1(13)=1.0-ZI**2
          HL1(14)=0.0
          HL1(15)=0.0
          !  FOR L2-COORDINATE
          HL2(1)= 0.0
          HL2(2)= 0.5*(4.0*X2-2.-ZI)*(1.0-ZI)
          HL2(3)= 0.0
          HL2(4)= 0.0
          HL2(5)= 0.5*(4.0*X2-2.+ZI)*(1.0+ZI)
          HL2(6)= 0.0
          HL2(7)= 2.0*X1*(1.0-ZI)
          HL2(8)= 2.0*X3*(1.0-ZI)
          HL2(9)= 0.0
          HL2(10)=2.0*X1*(1.0+ZI)
          HL2(11)=2.0*X3*(1.0+ZI)
          HL2(12)=0.0
          HL2(13)=0.0
          HL2(14)=1.0-ZI**2
          HL2(15)=0.0
          !  FOR L3-COORDINATE
          HL3(1)= 0.0
          HL3(2)= 0.0
          HL3(3)= 0.5*(4.0*X3-2.-ZI)*(1.0-ZI)
          HL3(4)= 0.0
          HL3(5)= 0.0
          HL3(6)= 0.5*(4.0*X3-2.+ZI)*(1.0+ZI)
          HL3(7)= 0.0
          HL3(8)= 2.0*X2*(1.0-ZI)
          HL3(9)= 2.0*X1*(1.0-ZI)
          HL3(10)=0.0
          HL3(11)=2.0*X2*(1.0+ZI)
          HL3(12)=2.0*X1*(1.0+ZI)
          HL3(13)=0.0
          HL3(14)=0.0
          HL3(15)=1.0-ZI**2
          !  FOR Z-COORDINATE
          HZ(1)= 0.5*X1*(-2.0*X1+1.0+2.0*ZI)
          HZ(2)= 0.5*X2*(-2.0*X2+1.0+2.0*ZI)
          HZ(3)= 0.5*X3*(-2.0*X3+1.0+2.0*ZI)
          HZ(4)= 0.5*X1*( 2.0*X1-1.0+2.0*ZI)
          HZ(5)= 0.5*X2*( 2.0*X2-1.0+2.0*ZI)
          HZ(6)= 0.5*X3*( 2.0*X3-1.0+2.0*ZI)
          HZ(7)= -2.0*X1*X2
          HZ(8)= -2.0*X2*X3
          HZ(9)= -2.0*X1*X3
          HZ(10)= 2.0*X1*X2
          HZ(11)= 2.0*X2*X3
          HZ(12)= 2.0*X1*X3
          HZ(13)=-2.0*X1*ZI
          HZ(14)=-2.0*X2*ZI
          HZ(15)=-2.0*X3*ZI
          !  JACOBI MATRIX
          XJ11=0.0
          XJ21=0.0
          XJ31=0.0
          XJ12=0.0
          XJ22=0.0
          XJ32=0.0
          XJ13=0.0
          XJ23=0.0
          XJ33=0.0
          do I=1,NN
            XJ11=XJ11+(HL1(I)-HL3(I))*XX(I)
            XJ21=XJ21+(HL2(I)-HL3(I))*XX(I)
            XJ31=XJ31+HZ(I)*XX(I)
            XJ12=XJ12+(HL1(I)-HL3(I))*YY(I)
            XJ22=XJ22+(HL2(I)-HL3(I))*YY(I)
            XJ32=XJ32+HZ(I)*YY(I)
            XJ13=XJ13+(HL1(I)-HL3(I))*ZZ(I)
            XJ23=XJ23+(HL2(I)-HL3(I))*ZZ(I)
            XJ33=XJ33+HZ(I)*ZZ(I)
          enddo
          !DETERMINANT OF JACOBIAN
          DET=XJ11*XJ22*XJ33 &
            +XJ12*XJ23*XJ31  &
            +XJ13*XJ21*XJ32  &
            -XJ13*XJ22*XJ31  &
            -XJ12*XJ21*XJ33  &
            -XJ11*XJ23*XJ32
          ! INVERSION OF JACOBIAN
          DUM=1.0/DET
          XJI11=DUM*( XJ22*XJ33-XJ23*XJ32)
          XJI21=DUM*(-XJ21*XJ33+XJ23*XJ31)
          XJI31=DUM*( XJ21*XJ32-XJ22*XJ31)
          XJI12=DUM*(-XJ12*XJ33+XJ13*XJ32)
          XJI22=DUM*( XJ11*XJ33-XJ13*XJ31)
          XJI32=DUM*(-XJ11*XJ32+XJ12*XJ31)
          XJI13=DUM*( XJ12*XJ23-XJ13*XJ22)
          XJI23=DUM*(-XJ11*XJ23+XJ13*XJ21)
          XJI33=DUM*( XJ11*XJ22-XJ12*XJ21)
          !  WEIGHT VALUE AT GAUSSIAN POINT
          WG=WGT(NG,L1)*WGT(NG,L2)*WGT(NG,LZ)*DET*(1.0-X2)*0.25

          ind1 = 1
          do J=1,NN*NDOF
            ind2 = 1
            do J2=1,J
              NUM=(J-1)*J/2+J2
              !DEBUG
              !               IF(fstrEIG%mastyp.EQ.2) THEN
              !                IF(MOD(j,NDOF).EQ.MOD(j2,NDOF)) THEN
              !                  SS(NUM)=SS(NUM)+H(ind1)*H(ind2)*WG*RHO
              !                ENDIF
              !               ELSE IF(fstrEIG%mastyp.EQ.1) THEN
              if(j.EQ.j2) then
                SS(NUM)=SS(NUM)+H(ind1)*H(ind2)*WG*RHO
                totdiag=totdiag+H(ind1)*H(ind2)*WG*RHO
              endif
              if(mod(j2,ndof).EQ.mod(j,ndof)) then
                totmass=totmass+H(ind1)*H(ind2)*WG*RHO
              endif
              !               ENDIF
              if(mod(j2,NDOF).EQ.0) ind2 = ind2 + 1
            enddo
            if(mod(j,NDOF).EQ.0) ind1 = ind1 + 1
          enddo
        enddo
      enddo
    enddo
    !DEBUG
    !      IF(fstrEIG%mastyp.EQ.1) THEN
    do j = 1,nn*ndof
      num = j*(j+1)/2
      ss(num) = ss(num)*(2*totmass-totdiag)/(totdiag)
    end do
    if(2*totmass-totdiag .LT. 0) stop "Mass error 352!"
    !      ENDIF
    return
  end subroutine MASS_C3D15
  !----------------------------------------------------------------------*
  subroutine MASS_C3D10(XX,YY,ZZ,EE,PP,RHO,SS,fstrEIG)
    !----------------------------------------------------------------------*
    !
    ! CALCULATION 3D 10-NODE SOLID ELEMENT
    !
    use hecmw
    use m_fstr
    use gauss_integration
    implicit none
    ! I/F VARIABLES
    real(kind=kreal) :: XX(*), YY(*), ZZ(*), SS(*), EE, PP, RHO
    ! LOCAL VARIABLES
    integer(kind=kint), parameter :: NN = 10, NDOF = 3, ISIZE = (NN*NDOF)*(NN*NDOF +1)/2
    integer(kind=kint), parameter :: NG = 3
    !parameter(NN=10, NDOF=3, ISIZE=(NN*NDOF)*(NN*NDOF + 1)/2, NG=3)
    real(kind=kreal)   :: D(6, 6), B(6, NDOF*NN), DB(6, NDOF*NN)
    real(kind=kreal)   :: H(NN), HL1(NN), HL2(NN), HL3(NN), HL4(NN)
    real(kind=kreal)   :: XJ11, XJ21, XJ31, XJ12, XJ22, XJ32, XJ13, XJ23, XJ33, DET, WG, DUM
    real(kind=kreal)   :: XJI11, XJI21, XJI31, XJI12, XJI22, XJI32, XJI13, XJI23, XJI33
    integer(kind=kint) :: I, J, L, L1, L2, L3, NUM, J2
    real(kind=kreal)   :: XL1, XL2, XL3
    real(kind=kreal)   :: X1, X2, X3, X4
    real(kind=kreal)   :: DNDX, DNDY, DNDZ
    !*EHM CONSISTENT MASS MATRIX 18 Apr 2004
    real(kind=kreal)   :: totdiag, totmass
    integer(kind=kint) :: ind1, ind2
    type(fstr_eigen)   :: fstrEIG

    totdiag = 0.0
    totmass = 0.0
    ! ZERO CLEAR MATRIX S()
    do I=1,ISIZE
      SS(I)=0.0
    enddo
    ! LOOP FOR INTEGRATION POINTS
    do L3=1,NG
      XL3=XG(NG,L3)
      X3 =(XL3+1.0)*0.5
      do L2=1,NG
        XL2=XG(NG,L2)
        X2 =(1.0-X3)*(XL2+1.0)*0.5
        do L1=1,NG
          XL1=XG(NG,L1)
          X1=(1.0-X2-X3)*(XL1+1.0)*0.5
          !  INTERPOLATION FUNCTION
          X4=1.0-X1-X2-X3
          H(1)=X1*(2.0*X1-1.0)
          H(2)=X2*(2.0*X2-1.0)
          H(3)=X3*(2.0*X3-1.0)
          H(4)=X4*(2.0*X4-1.0)
          H(5)=4.0*X1*X2
          H(6)=4.0*X2*X3
          H(7)=4.0*X1*X3
          H(8)=4.0*X1*X4
          H(9)=4.0*X2*X4
          H(10)=4.0*X3*X4
          ! DERIVATIVE OF INTERPOLATION FUNCTION
          ! FOR L1-COORDINATE
          HL1(1)= 4.0*X1-1.0
          HL1(2)= 0.0
          HL1(3)= 0.0
          HL1(4)= 0.0
          HL1(5)= 4.0*X2
          HL1(6)= 0.0
          HL1(7)= 4.0*X3
          HL1(8)= 4.0*X4
          HL1(9)= 0.0
          HL1(10)= 0.0
          !  FOR L2-COORDINATE
          HL2(1)= 0.0
          HL2(2)= 4.0*X2-1.0
          HL2(3)= 0.0
          HL2(4)= 0.0
          HL2(5)= 4.0*X1
          HL2(6)= 4.0*X3
          HL2(7)= 0.0
          HL2(8)= 0.0
          HL2(9)= 4.0*X4
          HL2(10)= 0.0
          !  FOR L3-COORDINATE
          HL3(1)= 0.0
          HL3(2)= 0.0
          HL3(3)= 4.0*X3-1.0
          HL3(4)= 0.0
          HL3(5)= 0.0
          HL3(6)= 4.0*X2
          HL3(7)= 4.0*X1
          HL3(8)= 0.0
          HL3(9)= 0.0
          HL3(10)= 4.0*X4
          !  FOR L4-COORDINATE
          HL4(1)= 0.0
          HL4(2)= 0.0
          HL4(3)= 0.0
          HL4(4)= 4.0*X4-1.0
          HL4(5)= 0.0
          HL4(6)= 0.0
          HL4(7)= 0.0
          HL4(8)= 4.0*X1
          HL4(9)= 4.0*X2
          HL4(10)= 4.0*X3
          !  JACOBI MATRIX
          XJ11=0.0
          XJ21=0.0
          XJ31=0.0
          XJ12=0.0
          XJ22=0.0
          XJ32=0.0
          XJ13=0.0
          XJ23=0.0
          XJ33=0.0
          do I=1,NN
            XJ11=XJ11+(HL1(I)-HL4(I))*XX(I)
            XJ21=XJ21+(HL2(I)-HL4(I))*XX(I)
            XJ31=XJ31+(HL3(I)-HL4(I))*XX(I)
            XJ12=XJ12+(HL1(I)-HL4(I))*YY(I)
            XJ22=XJ22+(HL2(I)-HL4(I))*YY(I)
            XJ32=XJ32+(HL3(I)-HL4(I))*YY(I)
            XJ13=XJ13+(HL1(I)-HL4(I))*ZZ(I)
            XJ23=XJ23+(HL2(I)-HL4(I))*ZZ(I)
            XJ33=XJ33+(HL3(I)-HL4(I))*ZZ(I)
          enddo
          !DETERMINANT OF JACOBIAN
          DET=XJ11*XJ22*XJ33    &
            +XJ12*XJ23*XJ31    &
            +XJ13*XJ21*XJ32    &
            -XJ13*XJ22*XJ31    &
            -XJ12*XJ21*XJ33    &
            -XJ11*XJ23*XJ32
          ! INVERSION OF JACOBIAN
          DUM=1.0/DET
          XJI11=DUM*( XJ22*XJ33-XJ23*XJ32)
          XJI21=DUM*(-XJ21*XJ33+XJ23*XJ31)
          XJI31=DUM*( XJ21*XJ32-XJ22*XJ31)
          XJI12=DUM*(-XJ12*XJ33+XJ13*XJ32)
          XJI22=DUM*( XJ11*XJ33-XJ13*XJ31)
          XJI32=DUM*(-XJ11*XJ32+XJ12*XJ31)
          XJI13=DUM*( XJ12*XJ23-XJ13*XJ22)
          XJI23=DUM*(-XJ11*XJ23+XJ13*XJ21)
          XJI33=DUM*( XJ11*XJ22-XJ12*XJ21)
          !
          DET=-DET
          !  WEIGHT VALUE AT GAUSSIAN POINT
          WG=WGT(NG,L1)*WGT(NG,L2)*WGT(NG,L3)*DET*(1.0-X3)*(1.0-X2-X3)*0.125

          ind1 = 1
          do J=1,NN*NDOF
            ind2 = 1
            do J2=1,J
              NUM=(J-1)*J/2+J2
              !DEBUG
              !               IF(fstrEIG%mastyp.EQ.2) THEN
              !                IF(MOD(j,NDOF).EQ.MOD(j2,NDOF)) THEN
              !                 SS(NUM)=SS(NUM)+H(ind1)*H(ind2)*WG*RHO
              !                ENDIF
              !               ELSE IF(fstrEIG%mastyp.EQ.1) THEN
              if(j.EQ.j2) then
                SS(NUM)=SS(NUM)+H(ind1)*H(ind2)*WG*RHO
                totdiag=totdiag+H(ind1)*H(ind2)*WG*RHO
              endif
              if(mod(j2,ndof).EQ.mod(j,ndof)) then
                totmass=totmass+H(ind1)*H(ind2)*WG*RHO
              endif
              !               ENDIF
              if(mod(j2,NDOF).EQ.0) ind2 = ind2 + 1
            enddo
            if(mod(j,NDOF).EQ.0) ind1 = ind1 + 1
          enddo
        enddo
      enddo
    enddo
    !DEBUG
    !      IF(fstrEIG%mastyp.EQ.1) THEN
    do j = 1,nn*ndof
      num = j*(j+1)/2
      ss(num) = ss(num)*(2*totmass-totdiag)/(totdiag)
    end do
    if(2*totmass-totdiag .LT. 0) stop "Mass error 342!"
    !      ENDIF
    return
  end subroutine MASS_C3D10

end module m_eigen_LIB_3d2mass


module m_calc_green
public

    real(8), parameter          ::  PI   = 3.1415926536d0
    real(8), parameter          ::  ZERO = 1d-6

    ! gts data
    integer, parameter          ::  n_max_vertex_number    = 480000, &
                                    n_max_edge_number      = 240000, &
                                    n_max_cell_number      = 240000

!    integer                     ::  n_vertex, n_edge, n_cell
 !   real(8),DIMENSION(:,:),ALLOCATABLE  ::  arr_vertex
 !   integer,DIMENSION(:,:),ALLOCATABLE  ::  arr_edge
 !   integer,DIMENSION(:,:),ALLOCATABLE  ::  arr_cell

    ! global parameters
    real(8), parameter          :: subd_az = 0.d0  ! Subduction azimuth (degree)
    real(8), parameter          :: rot_deg = 0.d0   ! Should be the same as used in mesh_gen
    real(8), parameter          ::  vpl1 = cos((90.d0 - subd_az+rot_deg)*PI/180.d0)   ! coord-1's component (east)
    real(8),  parameter          ::  vpl2 = -sin((90.d0 - subd_az+rot_deg)*PI/180.d0)  ! coord-2's component (south)

    real(8), parameter          ::  parm_nu  = (6.1d0**2-2.d0*3.5d0**2)/(2.d0*6.1d0**2-2.d0*3.5d0**2)
    real(8), parameter          ::  parm_miu = 30000.d0        ! rigidity (MPa)
    real(8), parameter          ::  parm_l   = ( 2.d0*parm_nu*parm_miu ) / (1.d0 - 2.d0*parm_nu)   ! lambda in Lame parameters (MPa)

end module m_calc_green


  function wopt (sDCM, clientTarg, e1, r, i1)

! ======================================================================
!
!    Negative of the imaginary part of optical potential.
!    Wopt is the negative of the W(r) defined in Becchetti & Greenlees.
!
!   Called by CASCAD
!
!   CEM95 written by S. G. Mashnik
!
!   Edited by A. J. Sierk,  LANL  T-2  February-March, 1996.
!   Edited by AJS, LANL T-2, December, 2011.
!   Edited by LMK, XCP-3, July 2013 (included error protection)
!
! ======================================================================

    use, intrinsic:: iso_fortran_env, only: int32, real64
    use standardDCMParams, only: zro, one, two, four

    implicit none
    class(StandardDCM),     intent(inout) :: sDCM
    class(StandardDCMData), intent(inout) :: clientTarg
    real(real64),           intent(in   ) :: e1
    real(real64),           intent(in   ) :: r
    integer(int32),         intent(in   ) :: i1
    real(real64)                          :: wopt

    real(real64) :: am, e, f, rm, temp, wsf, wv, x

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

    x = (clientTarg%numBaryons() - two*clientTarg%numProtons()) / &
         & clientTarg%numBaryons()
    e = e1*1000.d0
    if (i1 <= 0) then
       if (e <= 25.d0) then
!  Imaginary part of Becchetti & Greenlees neutron optical potential.
!  [Phys. Rev. 182, 1190 (1969)] 0 < E < 40 MeV.
          rm = 1.26d0*clientTarg%aTargThrd()
          am = 0.58d0
          wv = 0.22d0*e - 1.56d0
          wsf = 13.d0 - 0.25d0*e - 12.d0*x
       else
!  Imaginary part of Marshak, Langford, Tamura, & Wong neutron optical
!  potential [Phys. Rev. C 2, 1862 (1970)]. 2 < E < 129 MeV.
          rm = 1.21d0*clientTarg%aTargThrd()
          am = 0.6448d0
          wv = 0.459d0 + 0.111d0*e
          wsf = 4.28d0 - 0.0414d0*e
       endif
    else
       if (e <= 25.d0) then
!  Imaginary part of Becchetti & Greenlees proton optical potential.
          rm = 1.32d0*clientTarg%aTargThrd()
          am = 0.51d0 + 0.7d0*x
          wv = 0.22d0*e - 2.7d0
          wsf = 11.8d0 - 0.25d0*e + 12.d0*x
       else
!  Imaginary part of Menet, Gross, Malanify, & Zucker proton optical
!  potential [Phys. Rev. C 4, 1114 (1971)]  30 < E < 60 MeV.
          rm = 1.37d0*clientTarg%aTargThrd()
          am = 0.74d0 - 0.008d0*e + x
          wv = 1.2d0 + 0.09d0*e
          wsf = 4.2d0 - 0.05d0*e + 15.5d0*x
       endif
    endif
    wv = max (wv, zro)
    wsf = max (wsf, zro)
    if (am < div0Lim .and. am > -div0Lim) then
       am = div0Lim
       write(sDCM%io%message,1000) "76"
       call sDCM%io%print(4, 3, sDCM%io%message)
    end if
    temp = one + exp((r - rm)/am)
    if (temp < div0Lim .and. temp > -div0Lim) then
       temp = div0Lim
       write(sDCM%io%message,1000) "81"
       call sDCM%io%print(4, 3, sDCM%io%message)
    end if
    f = one/(temp)
!  df/dr = (f - 1)/(am*f)
    wopt = f*(wv + four*wsf*(one - f))
    return

! ======================================================================
1000 format("Divide by zero error prevented in 'wopt.f90' line(s) ", A)
! ======================================================================
  end function wopt


!	Obtain transformation.
subroutine gettrans(dimlatin,transname)
use transset
implicit none
!	Names of elements of transformation.
character(len=*),intent(out)::transname(:)
character(len=32),allocatable::transnames(:)
!	Dimension of input.
integer,intent(in)::dimlatin
!	Buffer.
character(len=4)::buff
!	degree of polynomial.

!	elementout is the output element.
!	i counts components and output elements.
!	io is an error flag.
!	j counts coefficients.
integer::degree,elementout,i,io,j
!	Existence of lower or upper bounds of polynomial range.
logical::lbmask,ubmask
!	Reference base of polynomial.
!	lb is the lower bound.
!	ub is the upper bound
real(kind=8)::base,lb,ub
!	Polynomial coefficients
real(kind=8),allocatable::coefficients(:),inweight(:)
namelist/transformation/transnames,components
namelist/transcomp/degree,elementout,inweight,lbmask,ubmask,base,lb,ub
namelist/polynomial/coefficients
!	Space needed for names.
allocate(transnames(size(transname)),inweight(dimlatin),stat=io)
if(io/=0) stop 'Allocation of transformation names failed.'
!	Default names.
do i=1,size(transname)
	write(buff,'(i4)') i
	transnames(i)='Transformation'//trim(adjustl(buff))
end do
!	Component count.
components=size(transname)

read(*,nml=transformation,iostat=io)
if(io/=0)stop 'Transformation names and number of components not successfully read.'
transname=transnames
!   Run over components.
if(components<1) components=size(transname)
allocate(degrees(components),inweights(dimlatin,components),elementsout(components),&
    lbmasks(components),ubmasks(components),bases(components),lbs(components),ubs(components),&
    stat=io)
if(io/=0) stop 'Allocation of transformation data failed.'
!	Set defaults and fix input.
do i=1,components
    degree=1
    elementout=i
    inweight=0.0_8
	inweight(min(i,dimlatin))=1.0_8
    lbmask=.FALSE.
    ubmask=.FALSE.
    lb=0.0_8
    ub=0.0_8
    base=0.0_8
    read(*,nml=transcomp,iostat=io)
    if(io/=0) stop 'Component data not successfully read for transformation.'
	degree=max(0,degree)
    degrees(i)=degree
	inweights(:,i)=inweight
	elementout=max(1,min(elementout,size(transnames)))
    elementsout(i)=elementout
    lbmasks(i)=lbmask
    ubmasks(i)=ubmask
    lbs(i)=lb
    ubs(i)=ub
    bases(i)=base
end do
allocate(coeff(sum(degrees)+components),stat=io)
if(io/=0) stop 'Allocation of transformation definition not successful.'
j=1
do i=1,components
    allocate(coefficients(0:degrees(i)),stat=io)
    coefficients(0:degrees(i))=0.0_8
    if(degrees(i)>0)coefficients(1)=1.0_8
    read(*,nml=polynomial,iostat=io)
    if(io/=0) stop 'Coefficients of polynomial not read correctly.'
    coeff(j:j+degrees(i))=coefficients
    deallocate(coefficients)
    j=j+degrees(i)+1
end do
return
end subroutine gettrans


      subroutine Spsi3pre (BDiag,  lhsK,  nvar, col, row)
c
c------------------------------------------------------------------------------
c This is the initialization routine for the Sparse-GMRES solver.
c It pre-preconditions the LHS mass matrix and sets up the
c sparse preconditioners. (pre-preconditioning is block diagonal
c scaling).
c
c input:
c     BDiag  (nshg,nvar,nvar)    : block diagonal scaling matrix
c                                  which is already LU factored.
c     lhsK(nvar*nvar,nnz_tot) : sparse LHS mass matrix
c
c output:
c     lhsK(nvar*nvar,nnz_tot)  : pre-preconditioned (scaled) mass matrix
c
c Nahid Razmara, Spring 2000.	(Sparse Matrix)
c------------------------------------------------------------------------------
c
      use pointer_data

      include "common.h"
c
        integer col(nshg+1),  row(nnz*nshg)
        integer sparseloc, c, c1
        real*8 lhsK(nvar*nvar,nnz_tot)
c
      dimension  BDiag(nshg,nvar,nvar)

c
c.... block-diagonal pre-precondition LHS
c
c
c.... reduce by columns, (left block diagonal preconditioning)
c
c     lhsK  <-- inverse(L^tilde) lhsK
c
c
      if(nflow.ne.5) then
         write(*,*)' spsi3pre.f assumed nflow=5'
         stop
      endif
c
      do i = 1, nshg
          do k = col(i), col(i+1)-1
c
            do ic = 2, nvar
              do j = 1, nvar
                id = (j-1) * nvar + ic
                do il = 1, ic-1
                  lhsK(id,k) = lhsK(id,k)
     &                       - BDiag(i,ic,ic-il) * lhsK(id-il,k)
                enddo
              enddo
            enddo
c
          enddo
        enddo

        do i = 1, nshg
c
            do k = col(i), col(i+1)-1
                j = row(k)
c
c.... reduce by rows, (right block diagonal preconditioning)
c
c     lhsK   <-- lhsK  inverse(U^tilde)
c
                  do jj = 1, nvar
                       lhsK(jj,k)  = BDiag(j,1,1)*lhsK(jj,k)
                  enddo
c
                  do ic = 2, nvar
                    do jj = 1, nvar
                      id = (ic-1) * nvar + jj
                      do il = 1, ic-1
                        iid = id - nvar * il
                        lhsK(id,k) = lhsK(id,k)
     &                             - BDiag(j,ic-il,ic) * lhsK(iid,k)
                      enddo
                      lhsK(id,k) = BDiag(j,ic,ic) * lhsK(id,k)
                    enddo
                  enddo
c
             enddo
        enddo
c
      return

      end


program stats_test
    use :: stats_mod, only : stats_t, init_stats, add_stats_value, mean_stats
    implicit none
    real :: value
    type(stats_t) :: stats
    integer :: i

    call init_stats(stats)
    do i = 1, 10
        call random_number(value)
        call add_stats_value(stats, value)
    end do
    print *, 'mean', mean_stats(stats)

end program stats_test


c
c
c ===================================================================
      subroutine step1(maxmx,meqn,mwaves,mbc,mx,q,aux,dx,dt,
     &              method,mthlim,cfl,f,fwave,s,amdq,apdq,dtdx)
!
!     # Take one time step, updating q.
!
!     ----------------------------------------------------------------------
!     # step1fw is a modified version of step1 to use fwave instead of wave.
!     # A modified Riemann solver rp1 must be used in conjunction with this
!     # routine, which returns fwave's instead of wave's.
!     # See http://amath.washington.edu/~claw/fwave.html
!
!     # Limiters are applied to the fwave's, and the only significant
!     # modification of this code is in the "do 110" loop, for the
!     # second order corrections.
!     ----------------------------------------------------------------------
!
!     method(1) = 1   ==>  Godunov method
!     method(1) = 2   ==>  Slope limiter method
!     mthlim(p)  controls what limiter is used in the pth family
!
!
!     amdq, apdq, fwave, s, and f are used locally:
!
!     amdq(1-mbc:maxmx+mbc, meqn) = left-going flux-differences
!     apdq(1-mbc:maxmx+mbc, meqn) = right-going flux-differences
!        e.g. amdq(i,m) = m'th component of A^- \Delta q from i'th Riemann
!                         problem (between cells i-1 and i).
!
!     fwave(1-mbc:maxmx+mbc, meqn, mwaves) = waves from solution of
!                                           Riemann problems,
!            fwave(i,m,mw) = mth component of jump in f across
!                           wave in family mw in Riemann problem between
!                           states i-1 and i.
!
!     s(1-mbc:maxmx+mbc, mwaves) = wave speeds,
!            s(i,mw) = speed of wave in family mw in Riemann problem between
!                      states i-1 and i.
!
!     f(1-mbc:maxmx+mbc, meqn) = correction fluxes for second order method
!            f(i,m) = mth component of flux at left edge of ith cell
!     --------------------------------------------------------------------
!     --------------------------------------------------------------------
!	  This version step1fw_geo.f  accumulates the updates
!       into interface fluxes.  It then relimits the interface fluxes so that
!       non-negativity of depth is maintained for depth averaged flow equations
!       where q(i,1) is the depth.
!
!       To enable this relimiting set relimit1=.true. and relimit2=.true.
!       To only relimit the second order correction fluxes, set relimit2=.true.

!       if relimit1 = relimit2 = .false. then it should behave the same as standard clawpack.
!
!       last modified 1/29/09, David George.
!     -----------------------------------------------------------------------

      implicit double precision (a-h,o-z)
      dimension    q(1-mbc:maxmx+mbc, meqn)
      dimension  aux(1-mbc:maxmx+mbc, *)
      dimension    f(1-mbc:maxmx+mbc, meqn)
      dimension    s(1-mbc:maxmx+mbc, mwaves)
      dimension fwave(1-mbc:maxmx+mbc, meqn, mwaves)
      dimension amdq(1-mbc:maxmx+mbc, meqn)
      dimension apdq(1-mbc:maxmx+mbc, meqn)
      dimension dtdx(1-mbc:maxmx+mbc)

      dimension method(7),mthlim(mwaves)
      dimension fp(2), fm(2), fi(2)

      logical limit,relimit1,relimit2

      common /geo/ grav,abs_tol
      common /fluxlimiting/ relimit1,relimit2
c
c     # check if any limiters are used:
      limit = .false.

      tol=abs_tol

      do 5 mw=1,mwaves
	 if (mthlim(mw) .gt. 0) limit = .true.
   5     continue
c
      mcapa = method(6)
      do 10 i=1-mbc,mx+mbc
	 if (mcapa.gt.0) then
	     if (aux(i,mcapa) .le. 0.d0) then
		write(6,*) 'Error -- capa must be positive'
		stop
		endif
             dtdx(i) = dt / (dx*aux(i,mcapa))
	    else
             dtdx(i) = dt/dx
	    endif
   10	 continue
c
c
c
c     # solve Riemann problem at each interface
c     -----------------------------------------
c      write(*,*) 'rp1'
      call rp1(maxmx,meqn,mwaves,mbc,mx,q,q,aux,aux,fwave,s,amdq,apdq)

c     # Modify q for Godunov update:
c     # Note this may not correspond to a conservative flux-differencing
c     # for equations not in conservation form.  It is conservative if
c     # amdq + apdq = f(q(i)) - f(q(i-1)).

c==================================Geoclaw===========================================
c     # if relimitall=.true. the fluctuations, amdq and apdq are converted
c     # to true interface fluxes.
c     # ordinarily amdq = f(q_{i-1/2}^-)-f(q(i-1)) and apdq = f(q(i))-f(q_{i-1/2}^+)
c     # relimitall makes amdq --> f(q_{i-1/2}^-) and apdq --> f(q_{i-1/2}^+)
c      write(*,*) 'relimit'
      if (relimit1) then
         do i=1,mx+1
            ! convert to interface fluxes
            ! fi is the flux in the cell center
            fi(1)=q(i,2)
            fi(2)= 0.d0
            if (q(i,1).gt.abs_tol) then
                fi(2) = 0.5d0*grav*(q(i,1))**2 + q(i,2)**2/q(i,1)
            endif
            ! note that fp refers to the right of cell i and fm the left
            do m=1,2
               fp(m) = amdq(i+1,m) + fi(m)
               fm(m) = fi(m) - apdq(i,m)
            enddo

            ! test if relimiting is necessary for cell i
            outdensity = dtdx(i)*
     &          (dmax1(0.d0,fp(1))-dmin1(0.d0,fm(1)))
            density = q(i,1)

            if (outdensity.gt.density) then ! limit interface fluxes

               ! call subroutine novaccum1(fp,fm,density,dtdx,meqn,meqnlim,tol)
               call novaccum1(fp,fm,density,dtdx(i),meqn,meqn,tol)

               !Note: only one of apdq or amdq at an interface is limited
               !      since apdq(1)=amdq(1), the mass flux at an interface
               !      and so apdq and amdq remove mass from only one cell.
               !      so limiting will not happen twice for i and i+1.

               ! determine fluctuations from newly limited interface fluxes.
               do m=1,2
                  sumi = apdq(i,m)+amdq(i,m)
                  apdq(i,m) = fi(m)-fm(m)
                  amdq(i,m) = sumi - apdq(i,m)
                  sumip = apdq(i+1,m) + amdq(i+1,m)
                  amdq(i+1,m) = fp(m) - fi(m)
                  apdq(i+1,m) = sumip - amdq(i+1,m)
               enddo
            endif
         enddo
      endif
c============================================================================

      do 40 i=1,mx+1
         do 39 m=1,meqn
            q(i,m) = q(i,m) - dtdx(i)*apdq(i,m)
            q(i-1,m) = q(i-1,m) - dtdx(i-1)*amdq(i,m)
   39       continue
   40    continue

c     # compute maximum wave speed:
      cfl = 0.d0
      do 50 mw=1,mwaves
	 do 45 i=1,mx+1
c          # if s>0 use dtdx(i) to compute CFL,
c          # if s<0 use dtdx(i-1) to compute CFL:
	   cfl = dmax1(cfl, dtdx(i)*s(i,mw), -dtdx(i-1)*s(i,mw))
   45      continue
   50    continue
c
      if (method(2) .eq. 1) go to 900
c
c     # compute correction fluxes for second order q_{xx} terms:
c     ----------------------------------------------------------
c
      do 100 m = 1, meqn
            do 100 i = 1-mbc, mx+mbc
               f(i,m) = 0.d0
  100          continue
c
c     # apply limiter to waves:
      if (limit) then
         call limiter(maxmx,meqn,mwaves,mbc,mx,fwave,s,mthlim)
         endif

c
      do 120 i=1,mx+1
	 do 120 m=1,meqn
	    do 110 mw=1,mwaves
	       dtdxave = 0.5d0 * (dtdx(i-1) + dtdx(i))
	       f(i,m) = f(i,m) + 0.5d0 * dsign(1.d0,s(i,mw))
     &		   * (1.d0 - dabs(s(i,mw))*dtdxave) * fwave(i,m,mw)
c

  110          continue
  120       continue
c
c
  140 continue
c
c     # update q by differencing correction fluxes
c     ============================================
c
c     # (Note:  Godunov update has already been performed above)

!     relimit the correction fluxes to ensure they maintain positivity of mass
      if (relimit2) then
         do i=1,mx+1
            ! test if relimiting is necessary for cell i
            outdensity=dtdx(i)*(dmax1(0.d0,f(i+1,1))-dmin1(0.d0,f(i,1)))
            density = q(i,1)
            if (outdensity.gt.density) then ! limit interface fluxes
               ! call subroutine novaccum1(fp,fm,density,dtdx,meqn,meqnlim,tol)
               call novaccum1(f(i+1,1:meqn),f(i,1:meqn),
     &                       density,dtdx(i),meqn,meqn,tol)
            endif
         enddo
      endif

c
      do 150 m=1,meqn
	 do 150 i=1,mx
	    q(i,m) = q(i,m) - dtdx(i) * (f(i+1,m) - f(i,m))
  150       continue
c
  900 continue
      return
      end


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2021 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program 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 General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine attach_3d(pneigh,pnode,nterms,ratio,dist,xil,etl,zel,
     &  loopa)
!
!     ataches node with coordinates in "pnode" to the face containing
!     "nterms" nodes with coordinates in field "pneigh" (nterms < 20).
!     cave: the coordinates are stored in pneigh(1..3,*)
!
      implicit none
!
      integer nterms,i,j,k,m,imin,jmin,kmin,im,jm,km,n,loopa
!
      real*8 ratio(20),pneigh(3,20),pnode(3),a,xi(-1:1,-1:1,-1:1),
     &  et(-1:1,-1:1,-1:1),ze(-1:1,-1:1,-1:1),p(3),distmin,d1,dist,
     &  xil,etl,zel,dx(3),al,dummy
!
      n=3
!
      d1=1.d0
!
      xi(0,0,0)=0.d0
      et(0,0,0)=0.d0
      ze(0,0,0)=0.d0
      call distattach_3d(xi(0,0,0),et(0,0,0),ze(0,0,0),pneigh,pnode,a,p,
     &     ratio,nterms)
      distmin=a
      imin=0
      jmin=0
      kmin=0
!
      do m=1,loopa
!
!     initialisation
!
         d1=d1/10.d0
!
         do i=-1,1
            do j=-1,1
               do k=-1,1
                  if((i.eq.0).and.(j.eq.0).and.(k.eq.0)) cycle
!
                  xi(i,j,k)=xi(0,0,0)+i*d1
                  et(i,j,k)=et(0,0,0)+j*d1
                  ze(i,j,k)=ze(0,0,0)+k*d1
!
!              check whether inside the (-1,1)x(-1,1)x(-1,1) domain
!
                  if((xi(i,j,k).le.1.d0).and.
     &               (xi(i,j,k).ge.-1.d0).and.
     &               (et(i,j,k).le.1.d0).and.
     &               (et(i,j,k).ge.-1.d0).and.
     &               (ze(i,j,k).le.1.d0).and.
     &               (ze(i,j,k).ge.-1.d0)) then
                     call distattach_3d(xi(i,j,k),et(i,j,k),ze(i,j,k),
     &                    pneigh,pnode,a,p,ratio,nterms)
!
!     checking for smallest initial distance
!
                     if(a.lt.distmin) then
                        distmin=a
                        imin=i
                        jmin=j
                        kmin=k
                     endif
                  endif
!
               enddo
            enddo
         enddo
!
!     minimizing the distance from the face to the node
!
         do
!
!     exit if minimum found
!
c            write(*,*) 'attach_3d',m,imin,jmin,kmin
            if((imin.eq.0).and.(jmin.eq.0).and.(kmin.eq.0)) exit
!
!           new center of 3x3x3 matrix
!
            xi(0,0,0)=xi(imin,jmin,kmin)
            et(0,0,0)=et(imin,jmin,kmin)
            ze(0,0,0)=ze(imin,jmin,kmin)
!
            im=imin
            jm=jmin
            km=kmin
!
            imin=0
            jmin=0
            kmin=0
!
            do i=-1,1
               do j=-1,1
                  do k=-1,1
                     if((i+im.lt.-1).or.(i+im.gt.1).or.
     &                  (j+jm.lt.-1).or.(j+jm.gt.1).or.
     &                  (k+km.lt.-1).or.(k+km.gt.1)) then
!
                        xi(i,j,k)=xi(0,0,0)+i*d1
                        et(i,j,k)=et(0,0,0)+j*d1
                        ze(i,j,k)=ze(0,0,0)+k*d1
!
!              check whether inside the (-1,1)x(-1,1)x(-1,1) domain
!
                        if((xi(i,j,k).le.1.d0).and.
     &                     (xi(i,j,k).ge.-1.d0).and.
     &                     (et(i,j,k).le.1.d0).and.
     &                     (et(i,j,k).ge.-1.d0).and.
     &                     (ze(i,j,k).le.1.d0).and.
     &                     (ze(i,j,k).ge.-1.d0)) then
                           call distattach_3d(xi(i,j,k),et(i,j,k),
     &                          ze(i,j,k),pneigh,pnode,a,p,ratio,nterms)
!
!                       check for new minimum
!
                           if(a.lt.distmin) then
                              distmin=a
                              imin=i
                              jmin=j
                              kmin=k
                           endif
                        endif
!
                     endif
                  enddo
               enddo
            enddo
         enddo
      enddo
!
      call distattach_3d(xi(0,0,0),et(0,0,0),ze(0,0,0),pneigh,pnode,a,p,
     &     ratio,nterms)
!
      do i=1,3
        pnode(i)=p(i)
      enddo
!
      dist=dsqrt(a)
!
      if((nterms.eq.20).or.(nterms.eq.8)) then
         xil=xi(0,0,0)
         etl=et(0,0,0)
         zel=ze(0,0,0)
      elseif((nterms.eq.4).or.(nterms.eq.10)) then
         xil=(xi(0,0,0)+1.d0)/2.d0
         etl=(et(0,0,0)+1.d0)/2.d0
         zel=(ze(0,0,0)+1.d0)/2.d0
         dx(1)=xil
         dx(2)=etl
         dx(3)=zel
         call insertsortd(dx,n)
c         call dsort(dx,iy,n,kflag)
         if(dx(3).gt.1.d-30) then
            al=dx(3)/(xil+etl+zel)
            xil=al*xil
            etl=al*etl
            zel=al*zel
         endif
      elseif((nterms.eq.6).or.(nterms.eq.15)) then
         xil=(xi(0,0,0)+1.d0)/2.d0
         etl=(et(0,0,0)+1.d0)/2.d0
         if(xil+etl.gt.1.d0) then
            dummy=xil
            xil=1.d0-etl
            etl=1.d0-dummy
         endif
         zel=ze(0,0,0)
      endif
!
      return
      end


!
!     --------------------------------------------------------------
!       T R E D 1
!     --------------------------------------------------------------
!
!
      SUBROUTINE TRED1(NM, N, A, D, E, E2)
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
!...Translated by Pacific-Sierra Research 77to90  4.3E  21:52:17  11/14/01
!...Switches:
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER , INTENT(IN) :: NM
      INTEGER , INTENT(IN) :: N
      REAL(DOUBLE) , INTENT(INOUT) :: A(NM,N)
      REAL(DOUBLE) , INTENT(INOUT) :: D(N)
      REAL(DOUBLE) , INTENT(INOUT) :: E(N)
      REAL(DOUBLE) , INTENT(OUT) :: E2(N)
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: I, J, K, L, II, JP1
      REAL(DOUBLE) :: F, G, H, SCALE
!-----------------------------------------------
!
!
!     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRED1,
!     NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON.
!     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971).
!
!     THIS SUBROUTINE REDUCES A REAL SYMMETRIC MATRIX
!     TO A SYMMETRIC TRIDIAGONAL MATRIX USING
!     ORTHOGONAL SIMILARITY TRANSFORMATIONS.
!
!     ON INPUT:
!
!        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
!          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
!          DIMENSION STATEMENT;
!
!        N IS THE ORDER OF THE MATRIX;
!
!        A CONTAINS THE REAL SYMMETRIC INPUT MATRIX.  ONLY THE
!          LOWER TRIANGLE OF THE MATRIX NEED BE SUPPLIED.
!
!     ON OUTPUT:
!
!        A CONTAINS INFORMATION ABOUT THE ORTHOGONAL TRANS-
!          FORMATIONS USED IN THE REDUCTION IN ITS STRICT LOWER
!          TRIANGLE.  THE FULL UPPER TRIANGLE OF A IS UNALTERED;
!
!        D CONTAINS THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX;
!
!        E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL
!          MATRIX IN ITS LAST N-1 POSITIONS.  E(1) IS SET TO ZERO;
!
!        E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E.
!          E2 MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED.
!
!     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW,
!     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
!
!     ------------------------------------------------------------------
!
      DO I = 1, N
         D(I) = A(I,I)
      END DO
!     :::::::::: FOR I=N STEP -1 UNTIL 1 DO -- ::::::::::
      DO II = 1, N
         I = N + 1 - II
         L = I - 1
         H = 0.0D0
         SCALE = 0.0D0
         IF (L < 1) GO TO 130
!     :::::::::: SCALE ROW (ALGOL TOL THEN NOT NEEDED) ::::::::::
         DO K = 1, L
            SCALE = SCALE + DABS(A(I,K))
         END DO
!
         IF (SCALE /= 0.0D0) GO TO 140
  130    CONTINUE
         E(I) = 0.0D0
         E2(I) = 0.0D0
         GO TO 290
!
  140    CONTINUE
         A(I,:L) = A(I,:L)/SCALE
         H = SUM(A(I,:L)*A(I,:L))
!
         E2(I) = SCALE*SCALE*H
         F = A(I,L)
         G = -DSIGN(DSQRT(H),F)
         E(I) = SCALE*G
         H = H - F*G
         A(I,L) = F - G
         IF (L /= 1) THEN
            F = 0.0D0
!
            DO J = 1, L
               G = 0.0D0
!     :::::::::: FORM ELEMENT OF A*U ::::::::::
               G = SUM(A(J,:J)*A(I,:J))
!
               JP1 = J + 1
               IF (L >= JP1) THEN
!
                  G = G + SUM(A(JP1:L,J)*A(I,JP1:L))
               ENDIF
!     :::::::::: FORM ELEMENT OF P ::::::::::
               E(J) = G/H
               F = F + E(J)*A(I,J)
            END DO
!
            H = F/(H + H)
!     :::::::::: FORM REDUCED A ::::::::::
            DO J = 1, L
               F = A(I,J)
               G = E(J) - H*F
               E(J) = G
!
               A(J,:J) = A(J,:J) - F*E(:J) - G*A(I,:J)
            END DO
         ENDIF
!
         A(I,:L) = SCALE*A(I,:L)
!
  290    CONTINUE
         H = D(I)
         D(I) = A(I,I)
         A(I,I) = H
      END DO
!
      RETURN
!     :::::::::: LAST CARD OF TRED1 ::::::::::
      END SUBROUTINE TRED1


CID                     BMD04M
CID   0901HS 15 150    $BMD04M DISCRIMINANT ANALYSIS FOR TWO GROUPS     M0400000
CIBJOB         ALTIO                                                    M0400010
CIBFTC D04M    LIST,M94,XR7                                             M0400020
C             DISCRIMINANT ANALYSIS - TWO GROUPS      JUNE  9, 1966     M0400030
C        THIS IS A SIFTED VERSION OF BMD04M ORIGINALLY WRITTEN IN       M0400040
C        FORTRAN II. SOME MODIFICATIONS WERE MADE TO MAKE IT OPERABLE   M0400050
C        AND SLIGHTLY MORE EFFICIENT THAN THE SIFTED VERSION.           M0400060
      DIMENSION X(2,25,300),SUM(2,25,25),TOTAL(2,25),D(25),B(25),Z(2,300M0400070
     1), MMM(25),  N(2),LL(25),DIV(2),C(25,25),DD(25),ZBAR(2),VARZ(2),  M0400080
     2LLL(25),IRANK(2,300),LX(25),LY(25),FMT(120)                       M0400090
C                                                                       M0400100
  343 FORMAT(56H1BMD04M - DISCRIMINANT ANALYSIS-TWO GROUPS - VERSION OF M0400110
     118HJUNE  9, 1966     ,/                                           M0400120
     241H HEALTH SCIENCES COMPUTING FACILITY, UCLA)                     M0400130
C                                                                       M0400140
      DATA A2,FINISH,A3/6HPROBLM,6HFINISH,6HSELECT/                     M0400150
      MTAPE=5                                                           M0400160
 6    READ (5,310)A1,PROB,K,N(1),N(2),NVG,NADD,NTAPE,NUM,KVR            M0400170
      IF(A1.EQ.A2)GO TO 110                                             M0400180
      IF(A1.EQ.FINISH)GO TO 100                                         M0400190
  107 WRITE (6,345)                                                     M0400200
      GO TO 100                                                         M0400210
  110 CALL TPWD(NTAPE,MTAPE)                                            M0400220
 116  WRITE (6,343)                                                     M0400230
      IF((K-1)*(K-26))112,107,107                                       M0400240
  112 K1=K+NADD                                                         M0400250
      IF((K1-1)*(K1-26))114,107,107                                     M0400260
  114 WRITE (6,339)PROB,K1                                              M0400270
      DO 117 I=1,2                                                      M0400280
      IF((N(I)-K1+1)*(N(I)-301))117,107,107                             M0400290
  117 CONTINUE                                                          M0400300
      NTRAN=0                                                           M0400310
      IERROR=0                                                          M0400320
      IF(KVR.GT.0.AND.KVR.LE.10)GO TO 118                               M0400330
      KVR=1                                                             M0400340
      WRITE(6,4000)                                                     M0400350
  118 KVR=KVR*12                                                        M0400360
      READ (5,344)(FMT(I),I=1,KVR)                                      M0400370
      DO 410 I=1,2                                                      M0400380
      NN=N(I)                                                           M0400390
      DO 410 J=1,NN                                                     M0400400
  410 READ (MTAPE,FMT)(X(I,L,J), L=1,K)                                 M0400410
      IF(NVG)21,21,500                                                  M0400420
  500 CALL TRNGEN(X,K,N,IERROR,2,NVG)                                   M0400430
      IF(IERROR) 10, 21, 21                                             M0400440
   10 DO 15 I=1,NUM                                                     M0400450
   15 READ (5,340)A1                                                    M0400460
      GO TO 6                                                           M0400470
   21 K=K1                                                              M0400480
      NSEL=0                                                            M0400490
      DO 35 M=1,2                                                       M0400500
      DIV(M)=N(M)                                                       M0400510
      DO 30 I=1,K                                                       M0400520
      LL(I)=I                                                           M0400530
      TOTAL(M,I)=0.0                                                    M0400540
      DO 30 L=I,K                                                       M0400550
      C(I,L)=0.0                                                        M0400560
      SUM(M,I,L)=0.0                                                    M0400570
      NN=N(M)                                                           M0400580
      DO 25 J=1,NN                                                      M0400590
  25  SUM(M,I,L)=SUM(M,I,L)+X(M,I,J)*X(M,L,J)                           M0400600
  30  SUM(M,L,I)=SUM(M,I,L)                                             M0400610
      DO 35 I=1,K                                                       M0400620
      NN=N(M)                                                           M0400630
      DO 35 J=1,NN                                                      M0400640
  35  TOTAL(M,I)=TOTAL(M,I)+X(M,I,J)                                    M0400650
      DO 37 I=1,K                                                       M0400660
  37  D(I)=TOTAL(1,I)/DIV(1)-TOTAL(2,I)/DIV(2)                          M0400670
      DO 38 I=1,K                                                       M0400680
  38  DD(I)=D(I)                                                        M0400690
      WRITE (6,313)                                                     M0400700
      WRITE (6,321)                                                     M0400710
      DO 36 I=1,2                                                       M0400720
      DO 36 J=1,K                                                       M0400730
  36  Z(I,J)=TOTAL(I,J)/DIV(I)                                          M0400740
      DO 39 I=1,K                                                       M0400750
  39  WRITE (6,314)I,Z(1,I),Z(2,I),D(I)                                 M0400760
      DO 40 I=1,K                                                       M0400770
      DO 40 L=1,K                                                       M0400780
      C(I,L)=SUM(1,I,L)+SUM(2,I,L)-TOTAL(1,I)*TOTAL(1,L)/DIV(1)-TOTAL(2,M0400790
     1I)*TOTAL(2,L)/DIV(2)                                              M0400800
  40  SUM(1,I,L)=C(I,L)                                                 M0400810
      WRITE (6,301)                                                     M0400820
      DO 42 I=1,K                                                       M0400830
  42  WRITE (6,302)(SUM(1,I,L),L=1,K)                                   M0400840
  43  CALL INVERT (C,K,DET,LX,LY)                                       M0400850
      WRITE (6,323)                                                     M0400860
      DO 44 I=1,K                                                       M0400870
  44  WRITE (6,302)(C(I,J),J=1,K)                                       M0400880
      DO 45 I=1,K                                                       M0400890
      B(I)=0.0                                                          M0400900
      DO 45 L=1,K                                                       M0400910
  45  B(I)=B(I)+C(I,L)*D(L)                                             M0400920
      WRITE (6,303)                                                     M0400930
      WRITE (6,302)(B(I),I=1,K)                                         M0400940
      DSQ=0.0                                                           M0400950
      DO 48I=1,K                                                        M0400960
      DO 48 J=1,K                                                       M0400970
  48  DSQ=DSQ+D(I)*D(J)*C(I,J)                                          M0400980
      DSQ=DSQ*(DIV(1)+DIV(2)-2.0)                                       M0400990
      WRITE (6,320)DSQ                                                  M0401000
      IDF=N(1)+N(2)-K-1                                                 M0401010
      DK=IDF                                                            M0401020
      FK=K                                                              M0401030
      VAL=DIV(1)*DIV(2)*DK/(FK*(DIV(1)+DIV(2))*(DIV(1)+DIV(2)-2.0))     M0401040
      VAL=VAL*DSQ                                                       M0401050
      WRITE (6,341)K,IDF,VAL                                            M0401060
      DO 50 M=1,2                                                       M0401070
      NN=N(M)                                                           M0401080
      DO 50 J=1,NN                                                      M0401090
      Z(M,J)=0.0                                                        M0401100
      DO 50 I=1,K                                                       M0401110
      LI=LL(I)                                                          M0401120
  50  Z(M,J)=Z(M,J)+B(I)*X(M,LI,J)                                      M0401130
      WRITE (6,322)                                                     M0401140
      DO 52 M=1,2                                                       M0401150
      NN=N(M)                                                           M0401160
      SUMZ=0.0                                                          M0401170
      SUMZSQ=0.0                                                        M0401180
      ZBAR(M)=0.0                                                       M0401190
      DIVN=N(M)                                                         M0401200
      VARZ(M)=0.0                                                       M0401210
      DO 51 I=1,NN                                                      M0401220
      SUMZ=SUMZ+Z(M,I)                                                  M0401230
  51  SUMZSQ=SUMZSQ+Z(M,I)**2                                           M0401240
      ZBAR(M)=SUMZ/DIVN                                                 M0401250
      VARZ(M)=(SUMZSQ-SUMZ**2/DIVN)/(DIVN-1.0)                          M0401260
      STDVZ=SQRT(VARZ(M))                                               M0401270
  52  WRITE (6,319)M,NN,ZBAR(M),VARZ(M),STDVZ                           M0401280
      WRITE (6,304)                                                     M0401290
      WRITE (6,324)                                                     M0401300
      DO 53 I=1,2                                                       M0401310
      DO 53 J=1,300                                                     M0401320
  53  IRANK (I,J)=0                                                     M0401330
      NTOTAL=N(1)+N(2)                                                  M0401340
      DO 70 I=1,NTOTAL                                                  M0401350
      HOLD=-(10.0**35.0)                                                M0401360
      DO 59 M=1,2                                                       M0401370
      NN=N(M)                                                           M0401380
      DO 59 J=1,NN                                                      M0401390
      IF(Z(M,J)-HOLD)59,59,54                                           M0401400
  54  IF(IRANK(M,J))55,55,59                                            M0401410
  55  MM=M                                                              M0401420
      JJ=J                                                              M0401430
      HOLD=Z(M,J)                                                       M0401440
  59  CONTINUE                                                          M0401450
      IRANK (MM,JJ)=999                                                 M0401460
      IF(MM-1)60,60,61                                                  M0401470
  60  WRITE (6,305)I,HOLD,JJ                                            M0401480
      GO TO 70                                                          M0401490
  61  WRITE (6,325)I,HOLD,JJ                                            M0401500
  70  CONTINUE                                                          M0401510
  71  IF(NUM) 6, 6, 72                                                  M0401520
  72  NSEL=NSEL+1                                                       M0401530
      WRITE (6,317)NSEL                                                 M0401540
      READ (5,340)A1,K,(LL(I), I=1,25)                                  M0401550
      IF(A1.EQ.A3)GO TO 74                                              M0401560
  73  WRITE (6,346)NSEL                                                 M0401570
      NUM=NUM-1                                                         M0401580
      GO TO 71                                                          M0401590
  74  WRITE (6,309)                                                     M0401600
      WRITE (6,307)(LL(I),I=1,K)                                        M0401610
      DO 76 I=1,K                                                       M0401620
      LLI=LL(I)                                                         M0401630
      DO 75 L=1,K                                                       M0401640
      LLLL=LL(L)                                                        M0401650
  75  C(I,L)=SUM(1,LLI,LLLL)                                            M0401660
  76  D(I)=DD(LLI)                                                      M0401670
      NUM=NUM-1                                                         M0401680
      GO TO 43                                                          M0401690
 301  FORMAT(36H0 SUM OF PRODUCTS OF DEV. FROM MEANS)                   M0401700
 302  FORMAT(7F16.5)                                                    M0401710
 303  FORMAT(36H0 DISCRIMINANT FUNCTION COEFFICIENTS)                   M0401720
 304  FORMAT(69H0          FIRST GROUP      SECOND GROUP    FIRST GROUP M0401730
     1 SECOND GROUP)                                                    M0401740
 305  FORMAT(1H I4,F17.5,17X,I12)                                       M0401750
 307  FORMAT(10I5)                                                      M0401760
 309  FORMAT(28H  VARIABLES USED IN FUNCTION)                           M0401770
 310  FORMAT(A6,A2,I2,2I3,4I2,46X,I2)                                   M0401780
 313  FORMAT(49H0 VARIABLE MEANS BY GROUP AND DIFFERENCE IN MEANS)      M0401790
 314  FORMAT(I5,2X,3F16.5)                                              M0401800
 317  FORMAT(1H0//15H  SELECTION NO.I4)                                 M0401810
 319  FORMAT(I7,I14,F17.5,2F20.5)                                       M0401820
 320  FORMAT(22H0 MAHALANOBIS DSQUARE=F16.5)                            M0401830
 321  FORMAT(57H  VARIABLE      MEAN 1          MEAN 2         DIFFERENCM0401840
     1E)                                                                M0401850
 322  FORMAT(79H0 POP. NO.    SAMPLE SIZE      MEAN Z            VARIANCM0401860
     1E Z         STD. DEV. Z)                                          M0401870
 323  FORMAT(47H0 INVERSE OF SUM OF PRODUCTS OF DEV. FROM MEANS)        M0401880
 324  FORMAT(66H  RANK       VALUES           VALUES         ITEM NO.   M0401890
     1  ITEM NO.)                                                       M0401900
 325  FORMAT(1H I4,17X,F17.5,12X,I13)                                   M0401910
 339  FORMAT(15H0 PROBLEM NO.  A2/21H  NUMBER OF VARIABLESI4)           M0401920
 340  FORMAT(A6,26I2)                                                   M0401930
 341  FORMAT(4H0 F(I2,1H,I3,2H)=F16.5)                                  M0401940
 344  FORMAT(12A6)                                                      M0401950
 345  FORMAT(37H0ERROR ON PROBLEM CARD OR DECK SET-UP)                  M0401960
 346  FORMAT(40H0 ERROR ON SELECTION CARD OR DECK SET-UPI4)             M0401970
 4000 FORMAT(1H023X71HNUMBER OF VARIABLE FORMAT CARDS INCORRECTLY SPECIFM0401980
     1IED, ASSUMED TO BE 1.)                                            M0401990
 100  IF(MTAPE-5)102,102,101                                            M0402000
  101 REWIND MTAPE                                                      M0402010
  102 STOP                                                              M0402020
      END                                                               M0402030
CIBFTC INVER   LIST,M94,XR7                                             M0402040
C             SUBROUTINE INVERT FOR BMD04M            JUNE  9, 1966     M0402050
      SUBROUTINE INVERT (A,N,D,L,M)                                     M0402060
C     PROGRAM FOR FINDING THE INVERSE OF A NXN MATRIX                   M0402070
      DIMENSION A(25,25),L(25),M(25)                                    M0402080
C     SEARCH FOR LARGEST ELEMENT                                        M0402090
      D=1.0                                                             M0402100
      DO80 K=1,N                                                        M0402110
      L(K)=K                                                            M0402120
      M(K)=K                                                            M0402130
      BIGA=A(K,K)                                                       M0402140
      DO20 I=K,N                                                        M0402150
      DO20 J=K,N                                                        M0402160
      IF(ABS(BIGA)-ABS(A(I,J))) 10,20,20                                M0402170
   10 BIGA=A(I,J)                                                       M0402180
      L(K)=I                                                            M0402190
      M(K)=J                                                            M0402200
   20 CONTINUE                                                          M0402210
C     INTERCHANGE ROWS                                                  M0402220
      J=L(K)                                                            M0402230
      IF(L(K)-K) 35,35,25                                               M0402240
   25 DO30 I=1,N                                                        M0402250
      HOLD=-A(K,I)                                                      M0402260
      A(K,I)=A(J,I)                                                     M0402270
   30 A(J,I)=HOLD                                                       M0402280
C     INTERCHANGE COLUMNS                                               M0402290
   35 I=M(K)                                                            M0402300
      IF(M(K)-K) 45,45,37                                               M0402310
   37 DO40 J=1,N                                                        M0402320
      HOLD=-A(J,K)                                                      M0402330
      A(J,K)=A(J,I)                                                     M0402340
   40 A(J,I)=HOLD                                                       M0402350
C     DIVIDE COLUMN BY MINUS PIVOT                                      M0402360
   45 DO55 I=1,N                                                        M0402370
   46 IF(I-K)50,55,50                                                   M0402380
   50 A(I,K)=A(I,K)/(-A(K,K))                                           M0402390
   55 CONTINUE                                                          M0402400
C     REDUCE MATRIX                                                     M0402410
      DO65 I=1,N                                                        M0402420
      DO65 J=1,N                                                        M0402430
   56 IF(I-K) 57,65,57                                                  M0402440
   57 IF(J-K) 60,65,60                                                  M0402450
   60 A(I,J)=A(I,K)*A(K,J)+A(I,J)                                       M0402460
   65 CONTINUE                                                          M0402470
C     DIVIDE ROW BY PIVOT                                               M0402480
      DO75 J=1,N                                                        M0402490
   68 IF(J-K)70,75,70                                                   M0402500
   70 A(K,J)=A(K,J)/A(K,K)                                              M0402510
   75 CONTINUE                                                          M0402520
C     CONTINUED PRODUCT OF PIVOTS                                       M0402530
      D=D*A(K,K)                                                        M0402540
C     REPLACE PIVOT BY RECIPROCAL                                       M0402550
      A(K,K)=1.0/A(K,K)                                                 M0402560
   80 CONTINUE                                                          M0402570
C     FINAL ROW AND COLUMN INTERCHANGE                                  M0402580
      K=N                                                               M0402590
  100 K=(K-1)                                                           M0402600
      IF(K) 150,150,103                                                 M0402610
  103 I=L(K)                                                            M0402620
      IF(I-K) 120,120,105                                               M0402630
  105 DO110 J=1,N                                                       M0402640
      HOLD=A(J,K)                                                       M0402650
      A(J,K)=-A(J,I)                                                    M0402660
  110 A(J,I)=HOLD                                                       M0402670
  120 J=M(K)                                                            M0402680
      IF(J-K) 100,100,125                                               M0402690
  125 DO130 I=1,N                                                       M0402700
      HOLD=A(K,I)                                                       M0402710
      A(K,I)=-A(J,I)                                                    M0402720
  130 A(J,I)=HOLD                                                       M0402730
      GO TO 100                                                         M0402740
  150 RETURN                                                            M0402750
      END                                                               M0402760
CIBFTC TPWDS   LIST,M94,XR7                                             M0402770
C             SUBROUTINE TPWD FOR BMD04M              JUNE  9, 1966     M0402780
      SUBROUTINE TPWD(NT1,NT2)                                          M0402790
      IF(NT1)40,10,12                                                   M0402800
 10   NT1=5                                                             M0402810
 12   IF(NT1-NT2)14,19,14                                               M0402820
   14 IF(NT2.EQ.5)GO TO 18                                              M0402830
   17 REWIND NT2                                                        M0402840
   19 IF(NT1-5)18,24,18                                                 M0402850
 18   IF(NT1-6)22,40,22                                                 M0402860
 22   REWIND NT1                                                        M0402870
 24   NT2=NT1                                                           M0402880
 28   RETURN                                                            M0402890
 40   WRITE (6,49)                                                      M0402900
       STOP                                                             M0402910
 49   FORMAT(25H ERROR ON TAPE ASSIGNMENT)                              M0402920
      END                                                               M0402930
CIBFTC TRNGE   LIST,M94,XR7                                             M0402940
C             SUBROUTINE TRNGEN FOR BMD04M            JUNE  9, 1966     M0402950
      SUBROUTINE TRNGEN (DATA,NVAR,NSAM,IERROR,NGRP,NVG)                M0402960
      DIMENSION DATA(2,25,300),NSAM(2)                                  M0402970
      ASN(XX)=ATAN(XX/SQRT(1.0-XX**2))                                  M0402980
      DATA A2/6HTRNGEN/                                                 M0402990
      MARY=0                                                            M0403000
      WRITE (6,1403)                                                    M0403010
      WRITE (6,1400)                                                    M0403020
      DO1000J=1,NVG                                                     M0403030
      READ (5,1100)A1,NEWA,LCODE,LVA,BNEW                               M0403040
      IF(A1.EQ.A2)GO TO 250                                             M0403050
  200 WRITE (6,1401)J                                                   M0403060
      IERROR=-999                                                       M0403070
  250 WRITE (6,1402)J,NEWA,LCODE,LVA,BNEW                               M0403080
      IF(-IERROR)251,251,1000                                           M0403090
  251 IF(LCODE*(LCODE-15))255,500,500                                   M0403100
  255 IF(LCODE-10)4,5,5                                                 M0403110
    5 NEWB=BNEW                                                         M0403120
    4 DO3000JJ=1,NGRP                                                   M0403130
      NN=NSAM(JJ)                                                       M0403140
      DO 300 I=1,NN                                                     M0403150
      D=DATA(JJ,LVA,I)                                                  M0403160
      GOTO(10,20,30,40,50,60,70,80,90,100,110,120,130,140),LCODE        M0403170
   10 IF(D)99,7,8                                                       M0403180
    7 D2=0.0                                                            M0403190
      GOTO3                                                             M0403200
    8 D2=SQRT(D)                                                        M0403210
      GOTO3                                                             M0403220
   20 IF(D)99,11,12                                                     M0403230
   11 D2=1.0                                                            M0403240
      GOTO3                                                             M0403250
   12 D2=SQRT(D)+SQRT(D+1.0)                                            M0403260
      GOTO3                                                             M0403270
   30 IF(-D)14,99,99                                                    M0403280
   14 D2=ALOG10(D)                                                      M0403290
      GO TO 3                                                           M0403300
   40 D2=EXP(D)                                                         M0403310
      GOTO3                                                             M0403320
   50 IF(-D)17,7,99                                                     M0403330
   17 IF(D-1.0)18,19,99                                                 M0403340
   19 D2=3.14159265/2.0                                                 M0403350
      GOTO3                                                             M0403360
   18 D2=ASN(SQRT(D))                                                   M0403370
      GOTO3                                                             M0403380
   60 FN=NN                                                             M0403390
      A=D/(FN+1.0)                                                      M0403400
      B=A+1.0/(FN+1.0)                                                  M0403410
      IF(A)99,23,24                                                     M0403420
   23 IF(-B)27,7,99                                                     M0403430
   27 D2=ASN(SQRT(B))                                                   M0403440
      GOTO3                                                             M0403450
   24 IF(B)99,28,29                                                     M0403460
   28 D2=ASN(SQRT(A))                                                   M0403470
      GOTO3                                                             M0403480
   29 A=SQRT(A)                                                         M0403490
      B=SQRT(B)                                                         M0403500
      D2=ASN(A)+ASN(B)                                                  M0403510
      GOTO3                                                             M0403520
   70 IF(D)31,99,31                                                     M0403530
   31 D2=1.0/D                                                          M0403540
      GOTO3                                                             M0403550
   80 D2=D+BNEW                                                         M0403560
      GOTO3                                                             M0403570
   90 D2=D*BNEW                                                         M0403580
      GOTO3                                                             M0403590
  100 IF(-D)33,7,99                                                     M0403600
   33 D2=D**NEWB                                                        M0403610
      GOTO3                                                             M0403620
  110 D2=D+DATA(JJ,NEWB,I)                                              M0403630
      GOTO3                                                             M0403640
  120 D2=D-DATA(JJ,NEWB,I)                                              M0403650
      GOTO3                                                             M0403660
  130 D2=D*DATA(JJ,NEWB,I)                                              M0403670
      GOTO3                                                             M0403680
  140 IF(DATA(JJ,NEWB,I))34,99,34                                       M0403690
   34 D2=D/DATA(JJ,NEWB,I)                                              M0403700
      GOTO3                                                             M0403710
   99 IF(MARY)43,44,44                                                  M0403720
   44 MARY=-999                                                         M0403730
      IERROR=-999                                                       M0403740
      WRITE (6,1404)J                                                   M0403750
   43 WRITE (6,1405)I                                                   M0403760
      GO TO 300                                                         M0403770
    3 DATA(JJ,NEWA,I)=D2                                                M0403780
  300 CONTINUE                                                          M0403790
      IF(IERROR)45,3000,3000                                            M0403800
   45 WRITE (6,1406)JJ                                                  M0403810
 3000 CONTINUE                                                          M0403820
      IF(IERROR)42,1000,1000                                            M0403830
  500 WRITE (6,1408)NEWA                                                M0403840
 1000 CONTINUE                                                          M0403850
      IF(IERROR) 42,1111,1111                                           M0403860
   42 WRITE (6,1407)                                                    M0403870
 1100 FORMAT(A6,I3,I2,I3,F6.0)                                          M0403880
 1400 FORMAT(46H0CARD    NEW     TRANS    ORIG.   ORIG. VAR(B)/45H  NO. M0403890
     1VARIABLE   CODE    VAR(A)   OR CONSTANT)                          M0403900
 1401 FORMAT(30H0ERROR ON TRANSGENERATION CARDI4)                       M0403910
 1402 FORMAT(2H  I2,I8,2I9,F15.5)                                       M0403920
 1403 FORMAT(1H06X,21HTRANSGENERATION CARDS)                            M0403930
 1404 FORMAT(30H0THE INSTRUCTIONS INDICATED ON 25H TRANSGENERATION CARD M0403940
     1NO.I2,4H RE-/29H SULTED IN THE VIOLATION OF A 31H RESTRICTION FOR M0403950
     2THIS TRANSFOR-/31H MATION. THE VIOLATION OCCURED 29H FOR THE ITEM M0403960
     3S LISTED BELOW./)                                                 M0403970
 1405 FORMAT(10H ITEM NO. I3)                                           M0403980
 1406 FORMAT(32H0ITEMS ABOVE ARE FROM GROUP NO. I2//)                   M0403990
 1407 FORMAT(41H0PROGRAM CANNOT CONTINUE FOR THIS PROBLEM)              M0404000
 1408 FORMAT(1H0,35X,95HILLEGAL TRANSGENERATION CODE SPECIFIED ON PRECEDM0404010
     1ING CARD. PROGRAM WILL PROCEED LEAVING VARIABLE,I3,11H UNCHANGED.)M0404020
 1111 RETURN                                                            M0404030
      END                                                               M0404040


        program chkio
c------------------------------------------------------------------c
c test suite for Part I : I/O routines.                            c
c tests the following : gen5pt.f, prtmt, readmt, amd pltmt.        c
c 1) generates a 100 x 100 5pt matrix,                             c
c 2) prints it with a given format in file 'first.mat'             c
c 3) reads the matrix from 'first.mat' using readmat               c
c 4) prints it again in file 'second.mat' in  a different format   c
c 5) makes 4 pic files to show the different options of pltmt.     c
c    these are in job0.pic, job01.pic, job10.pic, job11.pic        c
c                          coded by Y. Saad, RIACS, 08/31/1989.    c
c------------------------------------------------------------------c
      parameter (nxmax = 20, nmx = nxmax*nxmax)
      implicit real*8 (a-h,o-z)
      integer ia(nmx),ja(7*nmx),iau(nmx)
      real*8 a(7*nmx),rhs(3*nmx),al(6)
      character title*72, key*8, type*3, guesol*2
c----- open statements ----------------
      open (unit=7,file='first.mat')
      open (unit=8,file='second.mat')
      open (unit=20,file='job00.pic')
      open (unit=21,file='job01.pic')
      open (unit=22,file='job10.pic')
      open (unit=23,file='job11.pic')
c
c---- dimension of grid
c
      nx = 10
      ny = 10
      nz = 1
      al(1) = 1.0D0
      al(2) = 0.0D0
      al(3) = 2.3D1
      al(4) = 0.4D0
      al(5) = 0.0D0
      al(6) = 8.2D-2
c
c---- generate grid problem.
c
      call gen57pt (nx,ny,nz,al,0,n,a,ja,ia,iau,rhs)
c
c---- create the Harwell-Boeing matrix. Start by defining title,
c     and type. them define format and print it.
c
      write (title,9) nx, ny
 9    format('Five-point matrix on a square region',
     *  ' using a ',I2,' by ',I2,' grid *SPARSKIT*')
      key = 'Fivept10'
      type= 'RSA'
      ifmt = 5
      job = 3
      guesol = 'GX'
c
c define a right hand side of ones, an initial guess of two's
c and an exact solution of three's.
c
      do 2 k=1, 3*n
	 rhs(k) = real( 1 +  (k-1)/n )
 2    continue
c
      call prtmt (n,n,a,ja,ia,rhs,guesol,title,key,type,
     1	                  ifmt,job,7)
c---- read it again in same matrix a, ja, ia
       nmax = nmx
       nzmax = 7*nmx
      do 3 k=1, 3*n
	 rhs(k) = 0.0
 3    continue
       job = 3
c
       rewind 7
c
       nrhs = 3*n
c
       call readmt (nmax,nzmax,job,7,a,ja,ia,rhs,nrhs,guesol,
     1             nrow,ncol,nnz,title,key,type,ierr)
	 print *,  ' ierr = ', ierr, ' nrhs ' , nrhs
c
c matrix read.  print it again in a different format
c
      ifmt = 102
      ncol = nrow
      job = 3
c
      call prtmt (nrow,ncol,a,ja,ia,rhs,guesol,title,key,type,
     1	                  ifmt,job,8)
c
c---- print four pic files
c
      mode = 0
      do 10 i=1, 2
	 do 11 j=1, 2
	 job = (i-1)*10 +j-1
	 iout = 20+(i-1)*2+j-1
      call pltmt (nrow,ncol,mode,ja,ia,title,key,type,job,iout)
 11   continue
 10   continue
c--------
      stop
      end


c     program DRDNLAGB
c>> 2001-05-24 DRDNLAGB Krogh Minor change for making .f90 version.
c>> 1997-06-18 DRDNLAGB Krogh  Changes to improve C portability.
c>> 1994-11-02 DRDNLAGB Krogh  Changes to use M77CON
c>> 1994-09-14 DRDNLAGB CLL Set IV(OUTLEV) = 0 for comparing output.
c>> 1992-04-13 CLL Rename and reorder common block [D/S]KEY.
c>> 1992-02-03 CLL @ JPL
c>> 1990-07-02 CLL @ JPL
c>> 1990-06-27 CLL @ JPL
c>> 1990-06-14 CLL @ JPL
c>> 1990-03-28 CLL @ JPL
c     Demo driver for DNLAGB. A variant of the nonlinear LS code NL2SOL.
c     DNLAGB handles bounded variables.  Requires values of the function
c     and the Jacobian matrix.
c     ------------------------------------------------------------------
c--D replaces "?": DR?NLAGB, ?NLAGB, ?CALCR, ?CALCJ, ?IVSET, ?KEY
c     ------------------------------------------------------------------
      external DCALCR, DCALCJ
      integer  J, LIV, LV, MC, MDATA, NC, NDATA
      parameter(MDATA = 30, MC = 7)
      parameter(LIV = 82 + 4*MC)
      parameter(LV =  105 + MC*(MDATA + 2*MC + 21) + 2*MDATA)
      integer IV(LIV)
      integer F, OUTLEV, SOLPRT, STATPR, X0PRT
      parameter(F=10, OUTLEV=19, SOLPRT=22, STATPR=23, X0PRT=24)
      double precision BND(2,MC), COEF(MC), DOF, V(LV)
      data (BND(1,J),J=1,7) /  2*5.0d0,  5*0.0D0 /
      data (BND(2,J),J=1,7) / 2*10.0d0,  5*1.0d0 /
c     ------------------------------------------------------------------
      NDATA = MDATA
      NC = MC
      COEF(1) =    5.0d0
      COEF(2) =   10.0d0
      COEF(3) =    0.5d0
      COEF(4) =    0.5d0
      COEF(5) =    0.5d0
      COEF(6) =    0.5d0
      COEF(7) =    0.5d0

      print'(1x,a)',
     * 'Program DRDNLAGB.. Demo driver for DNLAGB.',
     * '   A variant of NL2SOL.',
     * '   DNLAGB requires values of the function and the Jacobian.',
     * '   DNLAGB handles bounds on variables.',
     * ' ',
     * 'Sample problem is a nonlinear curve fit to data.',
     * 'Model function is C3 + C4 * cos(C1*t) + C5 * sin(C1*t) +',
     * '                       C6 * cos(C2*t) + C7 * sin(C2*t) + Noise',
     * 'Data generated using',
     * '(C1, ..., C7) = (6, 9, 1, 0.5, 0.4, 0.2, 0.1)',
     * 'and Gaussian noise with mean 0 and',
     * 'sample standard deviation 0.001',
     * 'Setting lower bounds = ( 5, 5,0,0,0,0,0).',
     * 'Setting upper bounds = (10,10,1,1,1,1,1).',
     * ' '

      call DIVSET(1, IV, LIV, LV, V)
      IV( X0PRT) = 1
      IV(OUTLEV) = 0
      IV(STATPR) = 1
      IV(SOLPRT) = 1

      call DNLAGB(NDATA, NC, COEF, BND, DCALCR, DCALCJ, IV, LIV, LV, V)

      DOF = max(NDATA - NC, 1)
      print'(1x/1x,a,g12.4)',
     *    'SIGFAC: sqrt((2 * V(F))/DOF) =',
     *             sqrt(2.0d0 * V(F)/DOF)
      stop
      end
c     ==================================================================
      subroutine DCALCR(NDATA, NC, C, NCOUNT, RVEC)
c     Function evaluation to test nonlinear least squares computation.
c     Illustrates saving results in common between DCALCR and DCALCJ
c     to avoid recalculation of common subexpressions.
c     ------------------------------------------------------------------
      common/DKEY/C1, C2, S1, S2, KEY
      save  /DKEY/
      integer I, KEY, MDATA, NCOUNT, NDATA, NC
      parameter(MDATA = 30)
      double precision C(NC), C1(MDATA), C2(MDATA), DEL, RVEC(NDATA)
      double precision S1(MDATA), S2(MDATA), T, YDATA(MDATA)
      data YDATA /
     *     1.700641d0, 1.793512d0, 1.838309d0, 1.838416d0, 1.792204d0,
     *     1.700501d0, 1.579804d0, 1.426268d0, 1.260724d0, 1.084901d0,
     *     0.917094d0, 0.761920d0, 0.627304d0, 0.522146d0, 0.446645d0,
     *     0.404920d0, 0.392033d0, 0.409622d0, 0.453045d0, 0.510765d0,
     *     0.584554d0, 0.663109d0, 0.747613d0, 0.829439d0, 0.908496d0,
     *     0.983178d0, 1.051046d0, 1.114072d0, 1.171746d0, 1.227823d0/
c     ------------------------------------------------------------------
      T = 0.0D0
      DEL = 1.0D0 / 29.0D0
      KEY = NCOUNT
      do 10 I = 1,NDATA
         C1(I) = cos(C(1)*T)
         S1(I) = sin(C(1)*T)
         C2(I) = cos(C(2)*T)
         S2(I) = sin(C(2)*T)
         RVEC(I) = C(3) + C(4)*C1(I) + C(5)*S1(I) +
     *                    C(6)*C2(I) + C(7)*S2(I) -
     *                    YDATA(I)
         T = T + DEL
   10 continue
      return
      end
c     ==================================================================
      subroutine DCALCJ(NDATA, NC, C, NCOUNT, AJAC)
c     Jacobian evaluation to test nonlinear least squares computation.
c     ------------------------------------------------------------------
      common/DKEY/C1, C2, S1, S2, KEY
      save  /DKEY/
      integer I, KEY, MDATA, NCOUNT, NDATA, NC
      parameter(MDATA = 30)
      double precision AJAC(NDATA,NC), C(NC), C1(MDATA), C2(MDATA)
      double precision DEL, S1(MDATA), S2(MDATA), T
c     ------------------------------------------------------------------
      T = 0.0D0
      DEL = 1.0D0 / 29.0D0
      if(NCOUNT .eq. KEY) then
         do 10 I = 1,NDATA
            AJAC(I,1) = -C(4)*S1(I)*T + C(5)*C1(I)*T
            AJAC(I,2) = -C(6)*S2(I)*T + C(7)*C2(I)*T
            AJAC(I,3) = 1.0D0
            AJAC(I,4) = C1(I)
            AJAC(I,5) = S1(I)
            AJAC(I,6) = C2(I)
            AJAC(I,7) = S2(I)
            T = T + DEL
   10    continue
      else
         do 20 I = 1,NDATA
            AJAC(I,3) = 1.0D0
            AJAC(I,4) = cos(C(1)*T)
            AJAC(I,5) = sin(C(1)*T)
            AJAC(I,6) = cos(C(2)*T)
            AJAC(I,7) = sin(C(2)*T)
            AJAC(I,1) = -C(4)*AJAC(I,5)*T + C(5)*AJAC(I,4)*T
            AJAC(I,2) = -C(6)*AJAC(I,7)*T + C(7)*AJAC(I,6)*T
            T = T + DEL
   20    continue
      endif
      return
      end


x <= not a or not b;


!  *********************************************************************
!  *                                                                   *
!  *                         subroutine genfld                         *
!  *                                                                   *
!  *********************************************************************
!  Single Precision Version 1.1
!  Written by Gordon A. Fenton, DalTech, Jan 31, 2001
!  Latest Update: Feb 22, 2005
!
!  PURPOSE  generates a soil property field
!
!  DESCRIPTION
!  This routine generates a soil property field. The field may be
!  deterministic, white noise, or a correlated random field.
!
!  ARGUMENTS
!
!   istat	unit number connected to a file to which the input data is to
!		echoed if echo is true. (input)
!
!    pfld	real array of size at least (nxe x nye) which, on output,
!		will contain the underlying soil property field (ie, the
!		normally distributed field, if the property is random).
!		(output)
!
!       p	real vector of length at least 7 containing the statistics
!		of the soil property field. In particular,
!		   p(1) = soil property mean
!		   p(2) = soil property standard deviation,
!		   p(3) = soil property distribution type;
!			  = 0.0 if property is deterministic (at mean value)
!			  = 1.0 if property is normally distributed
!			  = 2.0 if property is lognormally distributed (logn)
!			  = 3.0 if property is bounded
!			  = 4.0 if property is a function of phi
!		   p(4) = lower bound (bounded), or mean log-property (logn),
!			  or constant in functional relationship (f(phi))
!		   p(5) = upper bound (bounded), or sd of log-property (logn),
!			  or slope in functional relationship (f(phi))
!		   p(6) = m parameter (if bounded), or function type (f(phi))
!			  where in the last case,
!				p(6) = 0.0 for 1*phi
!				p(6) = 1.0 for sin(phi)
!				p(6) = 2.0 for tan(phi)
!		   p(7) = s parameter (if bounded)
!		If the soil property is bounded or functional, then p(1) and
!		p(2) are ignored and the parameters c(4) through c(7)
!		completely describe the distribution (or function). (input)
!
!     nxe	integer giving the number of elements describing the soil
!		mass in the x-direction (horizontally). (input)
!
!     nye	integer giving the number of elements describing the soil
!		mass in the y-direction (vertically). (input)
!
!      XL	real value containing the physical size of the soil mass in
!		the x-direction (horizontally). (input)
!
!      YL	real value containing the physical size of the soil mass in
!		the y-direction (vertically). (input)
!
!  varfnc	character string containing the name of the variance
!		function controlling the random fields. Possible variance
!		functions are
!		`dlavx2' - 2-D exponentially decaying (Markov) model
!			   requires X- and Y-direction scales of fluctuation
!		`dlafr2' - 2-D isotropic fractional Gaussian noise model
!			   requires (H,delta) as parameters. In this case,
!			   thx is H, and delta is the minimum element
!			   dimension.
!		`dlsep2' - 2-D separable (1D x 1D) Markov model
!			   requires X- and Y-direction scales of fluctuation
!		`dlsfr2' - 2-D separable fractional Gaussian noise model
!			   requires (H_x,H_y,delta) as parameters. In this
!			   case, thx is H_x, thy is H_y, and delta is the
!			   minimum element dimension.
!		`dlspx2' - 2-D separable Gaussian decaying model
!			   requires X- and Y-direction scales of fluctuation
!		(input)
!
!   kseed	integer giving the seed to be used to initialize the
!		pseudo-random number generator. Subsequent runs using
!		the same seed will result in the same sequence of random
!		numbers. (input)
!
!
!  REVISION HISTORY:
!  1.1	reordered numbering of f(phi) function types (0=1,1=sin,2=tan)
!	(this only changed the documentation above) (Feb 22/05)
!------------------------------------------------------------------------
      subroutine genfld(istat,pfld,p,nxe,nye,XL,YL,varfnc,kseed,liid)
      real pfld(nxe,*), p(*)
      real XL, YL
      integer istat, nxe, nye, kseed
      character*(*) varfnc
      logical liid
      real*8   dlavx2, dlsep2, dlspx2, dlafr2, dlsfr2
      external dlavx2, dlsep2, dlspx2, dlafr2, dlsfr2
      data zero/0.0/, one/1.0/
      data half/0.5/, thrpt5/3.5/

      if( p(3) .lt. half ) then			! property is deterministic
         do 10 j = 1, nye
         do 10 i = 1, nxe
            pfld(i,j) = zero			! we'll add mean back on later
  10     continue
      elseif( liid ) then			! white noise field
         do 20 j = 1, nye
         do 20 i = 1, nxe
            pfld(i,j) = gausv(one)
  20     continue
      elseif( p(3) .lt. thrpt5 ) then		! generate standard normal
         if( varfnc .eq. 'dlavx2' ) then
            call las2g(pfld,nxe,nye,XL,YL,dlavx2,kseed,0,istat)
         elseif( varfnc .eq. 'dlsep2' ) then
            call las2g(pfld,nxe,nye,XL,YL,dlsep2,kseed,0,istat)
         elseif( varfnc .eq. 'dlspx2' ) then
            call las2g(pfld,nxe,nye,XL,YL,dlspx2,kseed,0,istat)
         elseif( varfnc .eq. 'dlafr2' ) then
            call las2g(pfld,nxe,nye,XL,YL,dlafr2,kseed,0,istat)
         elseif( varfnc .eq. 'dlsfr2' ) then
            call las2g(pfld,nxe,nye,XL,YL,dlsfr2,kseed,0,istat)
         endif
      endif
!						all done
      return
      end