!-------------------------------------------------------------------------------
! Copyright (c) 2016 The University of Tokyo
! This software is released under the MIT License, see LICENSE.txt
!-------------------------------------------------------------------------------
!> This module provides function to check input data of 3d static analysis
module m_precheck_LIB_3d
contains
  !***********************************************************************
  !  3D SOLID Element: PreCheck
  !  PRE_341(XX,YY,ZZ,vol,almax,almin)
  !  PRE_351(XX,YY,ZZ,vol,almax,almin)
  !  PRE_361(XX,YY,ZZ,vol,almax,almin)
  !  PRE_342(XX,YY,ZZ,vol,almax,almin)
  !  PRE_352(XX,YY,ZZ,vol,almax,almin)
  !  PRE_362(XX,YY,ZZ,vol,almax,almin)
  !----------------------------------------------------------------------*
  subroutine PRE_341( XX,YY,ZZ,vol,almax,almin )
    !----------------------------------------------------------------------*
    !
    ! CALCULATION 3D 4-NODE SOLID ELEMENT
    !
    use hecmw
    use gauss_integration
    implicit none
    ! I/F VARIABLES
    real(kind=kreal) XX(*),YY(*),ZZ(*),vol,almax,almin
    ! LOCAL VARIABLES
    integer(kind=kint) NN
    integer(kind=kint) NG
    parameter(NN=4,NG=2)
    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
    integer(kind=kint) I,L,L1,L2,L3
    real(kind=kreal) XL1,XL2,XL3
    real(kind=kreal) X1,X2,X3,X4
    real(kind=kreal) a1,a2,a3,a4,a5,a6
    !C
    vol = 0.0
    ! 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
          H(2)=X2
          H(3)=X3
          H(4)=X4
          ! DERIVATIVE OF INTERPOLATION FUNCTION
          ! FOR L1-COORDINATE
          HL1(1)= 1.0
          HL1(2)= 0.0
          HL1(3)= 0.0
          HL1(4)= 0.0
          ! FOR L2-COORDINATE
          HL2(1)= 0.0
          HL2(2)= 1.0
          HL2(3)= 0.0
          HL2(4)= 0.0
          ! FOR L3-COORDINATE
          HL3(1)= 0.0
          HL3(2)= 0.0
          HL3(3)= 1.0
          HL3(4)= 0.0
          ! FOR L4-COORDINATE
          HL4(1)= 0.0
          HL4(2)= 0.0
          HL4(3)= 0.0
          HL4(4)= 1.0
          ! 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+(HL4(I)-HL1(I))*XX(I)
            XJ21=XJ21+(HL4(I)-HL2(I))*XX(I)
            XJ31=XJ31+(HL4(I)-HL3(I))*XX(I)
            XJ12=XJ12+(HL4(I)-HL1(I))*YY(I)
            XJ22=XJ22+(HL4(I)-HL2(I))*YY(I)
            XJ32=XJ32+(HL4(I)-HL3(I))*YY(I)
            XJ13=XJ13+(HL4(I)-HL1(I))*ZZ(I)
            XJ23=XJ23+(HL4(I)-HL2(I))*ZZ(I)
            XJ33=XJ33+(HL4(I)-HL3(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
          ! WEIGT VALUE AT GAUSSIAN POINT
          WG=WGT(NG,L1)*WGT(NG,L2)*WGT(NG,L3)*DET*(1.0-X3)*(1.0-X2-X3)*0.125
          do I = 1, NN
            vol = vol + H(I)*WG
          enddo
        enddo
      enddo
    enddo

    a1 = sqrt( (xx(2)-xx(1))**2+(yy(2)-yy(1))**2+(zz(2)-zz(1))**2 )
    a2 = sqrt( (xx(3)-xx(2))**2+(yy(3)-yy(2))**2+(zz(3)-zz(2))**2 )
    a3 = sqrt( (xx(1)-xx(3))**2+(yy(1)-yy(3))**2+(zz(1)-zz(3))**2 )
    a4 = sqrt( (xx(4)-xx(1))**2+(yy(4)-yy(1))**2+(zz(4)-zz(1))**2 )
    a5 = sqrt( (xx(4)-xx(2))**2+(yy(4)-yy(2))**2+(zz(4)-zz(2))**2 )
    a6 = sqrt( (xx(4)-xx(3))**2+(yy(4)-yy(3))**2+(zz(4)-zz(3))**2 )
    almax = dmax1( a1,a2,a3,a4,a5,a6 )
    almin = dmin1( a1,a2,a3,a4,a5,a6 )

  end subroutine PRE_341
  !----------------------------------------------------------------------*
  subroutine PRE_351( XX,YY,ZZ,vol,almax,almin )
    !----------------------------------------------------------------------*
    !
    ! CALCULATION 3D 6-NODE SOLID ELEMENT
    !
    use hecmw
    use gauss_integration
    implicit none
    ! I/F VARIABLES
    integer(kind=kint) nline
    real(kind=kreal) XX(*),YY(*),ZZ(*),vol,tline,almax,almin
    ! LOCAL VARIABLES
    integer(kind=kint) NN
    integer(kind=kint) NG
    parameter(NN=6,NG=2)
    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
    real(kind=kreal) XJI11,XJI21,XJI31,XJI12,XJI22,XJI32,XJI13,XJI23,XJI33
    integer(kind=kint) I,L1,L2,LZ
    real(kind=kreal) X1,X2,X3,XL1,XL2,ZI
    real(kind=kreal) a1,a2,a3,a4,a5,a6,a7,a8,a9
    !C
    vol = 0.0
    ! 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)=X1*(1.0-ZI)*0.5
          H(2)=X2*(1.0-ZI)*0.5
          H(3)=X3*(1.0-ZI)*0.5
          H(4)=X1*(1.0+ZI)*0.5
          H(5)=X2*(1.0+ZI)*0.5
          H(6)=X3*(1.0+ZI)*0.5
          ! DERIVATIVE OF INTERPOLATION FUNCTION
          ! FOR L1-COORDINATE
          HL1(1)=(1.0-ZI)*0.5
          HL1(2)=0.0
          HL1(3)=0.0
          HL1(4)=(1.0+ZI)*0.5
          HL1(5)=0.0
          HL1(6)=0.0
          ! FOR L2-COORDINATE
          HL2(1)=0.0
          HL2(2)=(1.0-ZI)*0.5
          HL2(3)=0.0
          HL2(4)=0.0
          HL2(5)=(1.0+ZI)*0.5
          HL2(6)=0.0
          ! FOR L3-COORDINATE
          HL3(1)=0.0
          HL3(2)=0.0
          HL3(3)=(1.0-ZI)*0.5
          HL3(4)=0.0
          HL3(5)=0.0
          HL3(6)=(1.0+ZI)*0.5
          ! FOR Z-COORDINATE
          HZ(1)=-X1*0.5
          HZ(2)=-X2*0.5
          HZ(3)=-X3*0.5
          HZ(4)= X1*0.5
          HZ(5)= X2*0.5
          HZ(6)= X3*0.5
          ! 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
          ! WEIGHT VALUE AT GAUSSIAN POINT
          WG=WGT(NG,L1)*WGT(NG,L2)*WGT(NG,LZ)*DET*(1.0-X2)*0.25
          do I = 1, NN
            vol = vol + H(I)*WG
          enddo
        enddo
      enddo
    enddo

    a1 = sqrt( (xx(2)-xx(1))**2+(yy(2)-yy(1))**2+(zz(2)-zz(1))**2 )
    a2 = sqrt( (xx(3)-xx(2))**2+(yy(3)-yy(2))**2+(zz(3)-zz(2))**2 )
    a3 = sqrt( (xx(1)-xx(3))**2+(yy(1)-yy(3))**2+(zz(1)-zz(3))**2 )
    a4 = sqrt( (xx(5)-xx(4))**2+(yy(5)-yy(4))**2+(zz(5)-zz(4))**2 )
    a5 = sqrt( (xx(6)-xx(5))**2+(yy(6)-yy(5))**2+(zz(6)-zz(5))**2 )
    a6 = sqrt( (xx(4)-xx(6))**2+(yy(4)-yy(6))**2+(zz(4)-zz(6))**2 )
    a7 = sqrt( (xx(4)-xx(1))**2+(yy(4)-yy(1))**2+(zz(4)-zz(1))**2 )
    a8 = sqrt( (xx(5)-xx(2))**2+(yy(5)-yy(2))**2+(zz(5)-zz(2))**2 )
    a9 = sqrt( (xx(6)-xx(3))**2+(yy(6)-yy(3))**2+(zz(6)-zz(3))**2 )
    almax = dmax1( a1,a2,a3,a4,a5,a6,a7,a8,a9 )
    almin = dmin1( a1,a2,a3,a4,a5,a6,a7,a8,a9 )

  end subroutine PRE_351
  !----------------------------------------------------------------------*
  subroutine PRE_361( XX,YY,ZZ,vol,almax,almin )
    !----------------------------------------------------------------------*
    !
    ! CALCULATION 3D 8-NODE SOLID ELEMENT
    !
    use hecmw
    use gauss_integration
    implicit none
    ! I/F VARIABLES
    real(kind=kreal) XX(*),YY(*),ZZ(*),vol,almax,almin
    ! LOCAL VARIABLES
    integer(kind=kint) NN
    integer(kind=kint) NG
    parameter(NN=8,NG=2)
    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
    integer(kind=kint) I,LX,LY,LZ
    real(kind=kreal) a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12
    !C
    vol = 0.0
    ! 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
          H(2)=0.125*RP*SM*TM
          H(3)=0.125*RP*SP*TM
          H(4)=0.125*RM*SP*TM
          H(5)=0.125*RM*SM*TP
          H(6)=0.125*RP*SM*TP
          H(7)=0.125*RP*SP*TP
          H(8)=0.125*RM*SP*TP
          ! DERIVATIVE OF INTERPOLATION FUNCTION
          ! FOR R-COORDINATE
          HR(1)=-.125*SM*TM
          HR(2)= .125*SM*TM
          HR(3)= .125*SP*TM
          HR(4)=-.125*SP*TM
          HR(5)=-.125*SM*TP
          HR(6)= .125*SM*TP
          HR(7)= .125*SP*TP
          HR(8)=-.125*SP*TP
          ! FOR S-COORDINATE
          HS(1)=-.125*RM*TM
          HS(2)=-.125*RP*TM
          HS(3)= .125*RP*TM
          HS(4)= .125*RM*TM
          HS(5)=-.125*RM*TP
          HS(6)=-.125*RP*TP
          HS(7)= .125*RP*TP
          HS(8)= .125*RM*TP
          ! FOR T-COORDINATE
          HT(1)=-.125*RM*SM
          HT(2)=-.125*RP*SM
          HT(3)=-.125*RP*SP
          HT(4)=-.125*RM*SP
          HT(5)= .125*RM*SM
          HT(6)= .125*RP*SM
          HT(7)= .125*RP*SP
          HT(8)= .125*RM*SP
          ! 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
          ! WEIGHT VALUE AT GAUSSIAN POINT
          WG=WGT(NG,LX)*WGT(NG,LY)*WGT(NG,LZ)*DET
          do I=1,NN
            vol = vol + H(i)*WG
          enddo
        enddo
      enddo
    enddo

    a1 = sqrt( (xx(2)-xx(1))**2+(yy(2)-yy(1))**2+(zz(2)-zz(1))**2 )
    a2 = sqrt( (xx(3)-xx(2))**2+(yy(3)-yy(2))**2+(zz(3)-zz(2))**2 )
    a3 = sqrt( (xx(4)-xx(3))**2+(yy(4)-yy(3))**2+(zz(4)-zz(3))**2 )
    a4 = sqrt( (xx(1)-xx(4))**2+(yy(1)-yy(4))**2+(zz(1)-zz(4))**2 )

    a5 = sqrt( (xx(6)-xx(5))**2+(yy(6)-yy(5))**2+(zz(6)-zz(5))**2 )
    a6 = sqrt( (xx(7)-xx(6))**2+(yy(7)-yy(6))**2+(zz(7)-zz(6))**2 )
    a7 = sqrt( (xx(8)-xx(7))**2+(yy(8)-yy(7))**2+(zz(8)-zz(7))**2 )
    a8 = sqrt( (xx(5)-xx(8))**2+(yy(5)-yy(8))**2+(zz(5)-zz(8))**2 )

    a9 = sqrt( (xx(5)-xx(1))**2+(yy(5)-yy(1))**2+(zz(5)-zz(1))**2 )
    a10 = sqrt( (xx(6)-xx(2))**2+(yy(6)-yy(2))**2+(zz(6)-zz(2))**2 )
    a11 = sqrt( (xx(7)-xx(3))**2+(yy(7)-yy(3))**2+(zz(7)-zz(3))**2 )
    a12 = sqrt( (xx(8)-xx(4))**2+(yy(8)-yy(4))**2+(zz(8)-zz(4))**2 )
    almax = dmax1( a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12 )
    almin = dmin1( a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12 )

  end subroutine PRE_361
  !----------------------------------------------------------------------*
  subroutine PRE_342( XX,YY,ZZ,vol,almax,almin )
    !----------------------------------------------------------------------*
    !
    ! CALCULATION 3D 10-NODE SOLID ELEMENT
    !
    use hecmw
    use gauss_integration
    implicit none
    ! I/F VARIABLES
    real(kind=kreal) XX(*),YY(*),ZZ(*),vol,almax,almin
    ! LOCAL VARIABLES
    integer(kind=kint) NN
    integer(kind=kint) NG
    parameter(NN=10,NG=3)
    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
    integer(kind=kint) I,L1,L2,L3
    real(kind=kreal) XL1,XL2,XL3
    real(kind=kreal) X1,X2,X3,X4
    real(kind=kreal)  a1,a2,AL1,AL2,AL3,AL4,AL5,AL6
    !
    VOL = 0.0
    ! 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+(HL4(I)-HL1(I))*XX(I)
            XJ21=XJ21+(HL4(I)-HL2(I))*XX(I)
            XJ31=XJ31+(HL4(I)-HL3(I))*XX(I)
            XJ12=XJ12+(HL4(I)-HL1(I))*YY(I)
            XJ22=XJ22+(HL4(I)-HL2(I))*YY(I)
            XJ32=XJ32+(HL4(I)-HL3(I))*YY(I)
            XJ13=XJ13+(HL4(I)-HL1(I))*ZZ(I)
            XJ23=XJ23+(HL4(I)-HL2(I))*ZZ(I)
            XJ33=XJ33+(HL4(I)-HL3(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
          ! 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
          do I = 1, NN
            vol = vol + H(I)*WG
          enddo
        enddo
      enddo
    enddo

    a1 = sqrt( (xx(5)-xx(1))**2+(yy(5)-yy(1))**2+(zz(5)-zz(1))**2 )
    a2 = sqrt( (xx(2)-xx(5))**2+(yy(2)-yy(5))**2+(zz(2)-zz(5))**2 )
    AL1 = a1 + a2
    a1 = sqrt( (xx(6)-xx(2))**2+(yy(6)-yy(2))**2+(zz(6)-zz(2))**2 )
    a2 = sqrt( (xx(3)-xx(6))**2+(yy(3)-yy(6))**2+(zz(3)-zz(6))**2 )
    AL2 = a1 + a2
    a1 = sqrt( (xx(7)-xx(3))**2+(yy(7)-yy(3))**2+(zz(7)-zz(3))**2 )
    a2 = sqrt( (xx(1)-xx(7))**2+(yy(1)-yy(7))**2+(zz(1)-zz(7))**2 )
    AL3 = a1 + a2
    a1 = sqrt( (xx(8)-xx(1))**2+(yy(8)-yy(1))**2+(zz(8)-zz(1))**2 )
    a2 = sqrt( (xx(4)-xx(8))**2+(yy(4)-yy(8))**2+(zz(4)-zz(8))**2 )
    AL4 = a1 + a2
    a1 = sqrt( (xx(9)-xx(2))**2+(yy(9)-yy(2))**2+(zz(9)-zz(2))**2 )
    a2 = sqrt( (xx(4)-xx(9))**2+(yy(4)-yy(9))**2+(zz(4)-zz(9))**2 )
    AL5 = a1 + a2
    a1 = sqrt( (xx(10)-xx(3))**2+(yy(10)-yy(3))**2+(zz(10)-zz(3))**2 )
    a2 = sqrt( (xx(4)-xx(10))**2+(yy(4)-yy(10))**2+(zz(4)-zz(10))**2 )
    AL6 = a1 + a2
    almax = dmax1( AL1,AL2,AL3,AL4,AL5,AL6 )
    almin = dmin1( AL1,AL2,AL3,AL4,AL5,AL6 )

  end subroutine PRE_342
  !----------------------------------------------------------------------*
  subroutine PRE_352( XX,YY,ZZ,vol,almax,almin )
    !----------------------------------------------------------------------*
    !
    ! CALCULATION 3D 15-NODE SOLID ELEMENT
    !
    use hecmw
    use gauss_integration
    implicit none
    ! I/F VARIABLES
    real(kind=kreal) XX(*),YY(*),ZZ(*),vol,tline,almax,almin
    ! LOCAL VARIABLES
    integer(kind=kint) NN
    integer(kind=kint) NG
    parameter(NN=15,NG=3)
    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
    integer(kind=kint) I,L1,L2,LZ
    real(kind=kreal) X1,X2,X3,XL1,XL2,ZI
    real(kind=kreal) a1,a2,AL1,AL2,AL3,AL4,AL5,AL6,AL7,AL8,AL9
    !C
    vol = 0.0
    ! 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
          ! WEIGHT VALUE AT GAUSSIAN POINT
          WG=WGT(NG,L1)*WGT(NG,L2)*WGT(NG,LZ)*DET*(1.0-X2)*0.25
          do I = 1, NN
            vol = vol + H(I)*WG
          enddo
        enddo
      enddo
    enddo

    a1 = sqrt( (xx(7)-xx(1))**2+(yy(7)-yy(1))**2+(zz(7)-zz(1))**2 )
    a2 = sqrt( (xx(2)-xx(7))**2+(yy(2)-yy(7))**2+(zz(2)-zz(7))**2 )
    AL1 = a1 + a2
    a1 = sqrt( (xx(8)-xx(2))**2+(yy(8)-yy(2))**2+(zz(8)-zz(2))**2 )
    a2 = sqrt( (xx(3)-xx(8))**2+(yy(3)-yy(8))**2+(zz(3)-zz(8))**2 )
    AL2 = a1 + a2
    a1 = sqrt( (xx(9)-xx(3))**2+(yy(9)-yy(3))**2+(zz(9)-zz(3))**2 )
    a2 = sqrt( (xx(1)-xx(9))**2+(yy(1)-yy(9))**2+(zz(1)-zz(9))**2 )
    AL3 = a1 + a2

    a1 = sqrt( (xx(10)-xx(4))**2+(yy(10)-yy(4))**2+(zz(10)-zz(4))**2 )
    a2 = sqrt( (xx(5)-xx(10))**2+(yy(5)-yy(10))**2+(zz(5)-zz(10))**2 )
    AL4 = a1 + a2
    a1 = sqrt( (xx(11)-xx(5))**2+(yy(11)-yy(5))**2+(zz(11)-zz(5))**2 )
    a2 = sqrt( (xx(6)-xx(11))**2+(yy(6)-yy(11))**2+(zz(6)-zz(11))**2 )
    AL5 = a1 + a2
    a1 = sqrt( (xx(12)-xx(6))**2+(yy(12)-yy(6))**2+(zz(12)-zz(6))**2 )
    a2 = sqrt( (xx(4)-xx(12))**2+(yy(4)-yy(12))**2+(zz(4)-zz(12))**2 )
    AL6 = a1 + a2

    a1 = sqrt( (xx(13)-xx(1))**2+(yy(13)-yy(1))**2+(zz(13)-zz(1))**2 )
    a2 = sqrt( (xx(4)-xx(13))**2+(yy(4)-yy(13))**2+(zz(4)-zz(13))**2 )
    AL7 = a1 + a2
    a1 = sqrt( (xx(14)-xx(2))**2+(yy(14)-yy(2))**2+(zz(14)-zz(2))**2 )
    a2 = sqrt( (xx(5)-xx(14))**2+(yy(5)-yy(14))**2+(zz(5)-zz(14))**2 )
    AL8 = a1 + a2
    a1 = sqrt( (xx(15)-xx(3))**2+(yy(15)-yy(3))**2+(zz(15)-zz(3))**2 )
    a2 = sqrt( (xx(6)-xx(15))**2+(yy(6)-yy(15))**2+(zz(6)-zz(15))**2 )
    AL9 = a1 + a2

    almax = dmax1( AL1,AL2,AL3,AL4,AL5,AL6,AL7,AL8,AL9 )
    almin = dmin1( AL1,AL2,AL3,AL4,AL5,AL6,AL7,AL8,AL9 )

  end subroutine PRE_352
  !----------------------------------------------------------------------*
  subroutine PRE_362( XX,YY,ZZ,vol,almax,almin )
    !----------------------------------------------------------------------*
    !
    ! CALCULATION 3D 20-NODE SOLID ELEMENT
    !
    use hecmw
    use gauss_integration
    implicit none
    ! I/F VARIABLES
    real(kind=kreal) XX(*),YY(*),ZZ(*),vol,almax,almin
    ! LOCAL VARIABLES
    integer(kind=kint) NN
    integer(kind=kint) NG
    parameter(NN=20,NG=3)
    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
    integer(kind=kint) I,LX,LY,LZ
    real(kind=kreal)  a1,a2,AL1,AL2,AL3,AL4,AL5,AL6,AL7,AL8,AL9,AL10,AL11,AL12
    !C
    vol = 0.0
    ! 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
          ! WEIGHT VALUE AT GAUSSIAN POINT
          WG=WGT(NG,LX)*WGT(NG,LY)*WGT(NG,LZ)*DET
          do I=1,NN
            vol = vol + H(I)*WG
          enddo
        enddo
      enddo
    enddo

    a1 = sqrt( (xx(9)-xx(1))**2+(yy(9)-yy(1))**2+(zz(9)-zz(1))**2 )
    a2 = sqrt( (xx(2)-xx(9))**2+(yy(2)-yy(9))**2+(zz(2)-zz(9))**2 )
    AL1 = a1 + a2
    a1 = sqrt( (xx(10)-xx(2))**2+(yy(10)-yy(2))**2+(zz(10)-zz(2))**2 )
    a2 = sqrt( (xx(3)-xx(10))**2+(yy(3)-yy(10))**2+(zz(3)-zz(10))**2 )
    AL2 = a1 + a2
    a1 = sqrt( (xx(11)-xx(3))**2+(yy(11)-yy(3))**2+(zz(11)-zz(3))**2 )
    a2 = sqrt( (xx(4)-xx(11))**2+(yy(4)-yy(11))**2+(zz(4)-zz(11))**2 )
    AL3 = a1 + a2
    a1 = sqrt( (xx(12)-xx(4))**2+(yy(12)-yy(4))**2+(zz(12)-zz(4))**2 )
    a2 = sqrt( (xx(1)-xx(12))**2+(yy(1)-yy(12))**2+(zz(1)-zz(12))**2 )
    AL4 = a1 + a2

    a1 = sqrt( (xx(13)-xx(5))**2+(yy(13)-yy(5))**2+(zz(13)-zz(5))**2 )
    a2 = sqrt( (xx(6)-xx(13))**2+(yy(6)-yy(13))**2+(zz(6)-zz(13))**2 )
    AL5 = a1 + a2
    a1 = sqrt( (xx(14)-xx(6))**2+(yy(14)-yy(6))**2+(zz(14)-zz(6))**2 )
    a2 = sqrt( (xx(7)-xx(14))**2+(yy(7)-yy(14))**2+(zz(7)-zz(14))**2 )
    AL6 = a1 + a2
    a1 = sqrt( (xx(15)-xx(7))**2+(yy(15)-yy(7))**2+(zz(15)-zz(7))**2 )
    a2 = sqrt( (xx(8)-xx(15))**2+(yy(8)-yy(15))**2+(zz(8)-zz(15))**2 )
    AL7 = a1 + a2
    a1 = sqrt( (xx(16)-xx(8))**2+(yy(16)-yy(8))**2+(zz(16)-zz(8))**2 )
    a2 = sqrt( (xx(5)-xx(16))**2+(yy(5)-yy(16))**2+(zz(5)-zz(16))**2 )
    AL8 = a1 + a2

    a1 = sqrt( (xx(17)-xx(1))**2+(yy(17)-yy(1))**2+(zz(17)-zz(1))**2 )
    a2 = sqrt( (xx(5)-xx(17))**2+(yy(5)-yy(17))**2+(zz(5)-zz(17))**2 )
    AL9 = a1 + a2
    a1 = sqrt( (xx(18)-xx(2))**2+(yy(18)-yy(2))**2+(zz(18)-zz(2))**2 )
    a2 = sqrt( (xx(6)-xx(18))**2+(yy(6)-yy(18))**2+(zz(6)-zz(18))**2 )
    AL10 = a1 + a2
    a1 = sqrt( (xx(19)-xx(3))**2+(yy(19)-yy(3))**2+(zz(19)-zz(3))**2 )
    a2 = sqrt( (xx(7)-xx(19))**2+(yy(7)-yy(19))**2+(zz(7)-zz(19))**2 )
    AL11 = a1 + a2
    a1 = sqrt( (xx(20)-xx(4))**2+(yy(20)-yy(4))**2+(zz(20)-zz(4))**2 )
    a2 = sqrt( (xx(8)-xx(20))**2+(yy(8)-yy(20))**2+(zz(8)-zz(20))**2 )
    AL12 = a1 + a2

    almax = dmax1( AL1,AL2,AL3,AL4,AL5,AL6,AL7,AL8,AL9,AL10,AL11,AL12 )
    almin = dmin1( AL1,AL2,AL3,AL4,AL5,AL6,AL7,AL8,AL9 ,AL10,AL11,AL12)

  end subroutine PRE_362
end module m_precheck_LIB_3d


      SUBROUTINE TG01HD( JOBCON, COMPQ, COMPZ, N, M, P, A, LDA, E, LDE,
     $                   B, LDB, C, LDC, Q, LDQ, Z, LDZ, NCONT, NIUCON,
     $                   NRBLCK, RTAU, TOL, IWORK, DWORK, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To compute orthogonal transformation matrices Q and Z which
C     reduce the N-th order descriptor system (A-lambda*E,B,C)
C     to the form
C
C                ( Ac  *  )             ( Ec  *  )           ( Bc )
C       Q'*A*Z = (        ) ,  Q'*E*Z = (        ) ,  Q'*B = (    ) ,
C                ( 0  Anc )             ( 0  Enc )           ( 0  )
C
C          C*Z = ( Cc Cnc ) ,
C
C     where the NCONT-th order descriptor system (Ac-lambda*Ec,Bc,Cc)
C     is a finite and/or infinite controllable. The pencil
C     Anc - lambda*Enc is regular of order N-NCONT and contains the
C     uncontrollable finite and/or infinite eigenvalues of the pencil
C     A-lambda*E.
C
C     For JOBCON = 'C' or 'I', the pencil ( Bc Ec-lambda*Ac ) has full
C     row rank NCONT for all finite lambda and is in a staircase form
C     with
C                     _      _          _        _
C                   ( E1,0   E1,1  ...  E1,k-1   E1,k  )
C                   (        _          _        _     )
C       ( Bc Ec ) = (  0     E2,1  ...  E2,k-1   E2,k  ) ,  (1)
C                   (              ...  _        _     )
C                   (  0       0   ...  Ek,k-1   Ek,k  )
C
C                     _          _        _
C                   ( A1,1  ...  A1,k-1   A1,k  )
C                   (            _        _     )
C         Ac      = (   0   ...  A2,k-1   A2,k  ) ,         (2)
C                   (       ...           _     )
C                   (   0   ...    0      Ak,k  )
C           _
C     where Ei,i-1 is an rtau(i)-by-rtau(i-1) full row rank matrix
C                            _
C     (with rtau(0) = M) and Ai,i is an rtau(i)-by-rtau(i)
C     upper triangular matrix.
C
C     For JOBCON = 'F', the pencil ( Bc Ac-lambda*Ec ) has full
C     row rank NCONT for all finite lambda and is in a staircase form
C     with
C                     _     _          _        _
C                   ( A1,0  A1,1  ...  A1,k-1   A1,k  )
C                   (       _          _        _     )
C       ( Bc Ac ) = (  0    A2,1  ...  A2,k-1   A2,k  ) ,   (3)
C                   (             ...  _        _     )
C                   (  0      0   ...  Ak,k-1   Ak,k  )
C
C                     _          _        _
C                   ( E1,1  ...  E1,k-1   E1,k  )
C                   (            _        _     )
C         Ec      = (   0   ...  E2,k-1   E2,k  ) ,         (4)
C                   (       ...           _     )
C                   (   0   ...    0      Ek,k  )
C           _
C     where Ai,i-1 is an rtau(i)-by-rtau(i-1) full row rank matrix
C                            _
C     (with rtau(0) = M) and Ei,i is an rtau(i)-by-rtau(i)
C     upper triangular matrix.
C
C     For JOBCON = 'C', the (N-NCONT)-by-(N-NCONT) regular pencil
C     Anc - lambda*Enc has the form
C
C                         ( Ainc - lambda*Einc         *          )
C      Anc - lambda*Enc = (                                       ) ,
C                         (        0           Afnc - lambda*Efnc )
C
C     where:
C       1) the NIUCON-by-NIUCON regular pencil Ainc - lambda*Einc,
C          with Ainc upper triangular and nonsingular, contains the
C          uncontrollable infinite eigenvalues of A - lambda*E;
C       2) the (N-NCONT-NIUCON)-by-(N-NCONT-NIUCON) regular pencil
C          Afnc - lambda*Efnc, with Efnc upper triangular and
C          nonsingular, contains the uncontrollable finite
C          eigenvalues of A - lambda*E.
C
C     Note: The significance of the two diagonal blocks can be
C           interchanged by calling the routine with the
C           arguments A and E interchanged. In this case,
C           Ainc - lambda*Einc contains the uncontrollable zero
C           eigenvalues of A - lambda*E, while Afnc - lambda*Efnc
C           contains the uncontrollable nonzero finite and infinite
C           eigenvalues of A - lambda*E.
C
C     For JOBCON = 'F', the pencil Anc - lambda*Enc has the form
C
C        Anc - lambda*Enc = Afnc - lambda*Efnc ,
C
C     where the regular pencil Afnc - lambda*Efnc, with Efnc
C     upper triangular and nonsingular, contains the uncontrollable
C     finite eigenvalues of A - lambda*E.
C
C     For JOBCON = 'I', the pencil Anc - lambda*Enc has the form
C
C        Anc - lambda*Enc = Ainc - lambda*Einc ,
C
C     where the regular pencil Ainc - lambda*Einc, with Ainc
C     upper triangular and nonsingular, contains the uncontrollable
C     nonzero finite and infinite eigenvalues of A - lambda*E.
C
C     The left and/or right orthogonal transformations Q and Z
C     performed to reduce the system matrices can be optionally
C     accumulated.
C
C     The reduced order descriptor system (Ac-lambda*Ec,Bc,Cc) has
C     the same transfer-function matrix as the original system
C     (A-lambda*E,B,C).
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOBCON  CHARACTER*1
C             = 'C':  separate both finite and infinite uncontrollable
C                     eigenvalues;
C             = 'F':  separate only finite uncontrollable eigenvalues:
C             = 'I':  separate only nonzero finite and infinite
C                     uncontrollable eigenvalues.
C
C     COMPQ   CHARACTER*1
C             = 'N':  do not compute Q;
C             = 'I':  Q is initialized to the unit matrix, and the
C                     orthogonal matrix Q is returned;
C             = 'U':  Q must contain an orthogonal matrix Q1 on entry,
C                     and the product Q1*Q is returned.
C
C     COMPZ   CHARACTER*1
C             = 'N':  do not compute Z;
C             = 'I':  Z is initialized to the unit matrix, and the
C                     orthogonal matrix Z is returned;
C             = 'U':  Z must contain an orthogonal matrix Z1 on entry,
C                     and the product Z1*Z is returned.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The dimension of the descriptor state vector; also the
C             order of square matrices A and E, the number of rows of
C             matrix B, and the number of columns of matrix C.  N >= 0.
C
C     M       (input) INTEGER
C             The dimension of descriptor system input vector; also the
C             number of columns of matrix B.  M >= 0.
C
C     P       (input) INTEGER
C             The dimension of descriptor system output vector; also the
C             number of rows of matrix C.  P >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the N-by-N state matrix A.
C             On exit, the leading N-by-N part of this array contains
C             the transformed state matrix Q'*A*Z,
C
C                                ( Ac   *  )
C                       Q'*A*Z = (         ) ,
C                                ( 0   Anc )
C
C             where Ac is NCONT-by-NCONT and Anc is
C             (N-NCONT)-by-(N-NCONT).
C             If JOBCON = 'F', the matrix ( Bc Ac ) is in the
C             controllability staircase form (3).
C             If JOBCON = 'C' or 'I', the submatrix Ac is upper
C             triangular.
C             If JOBCON = 'C', the Anc matrix has the form
C
C                             ( Ainc   *  )
C                       Anc = (           ) ,
C                             (  0   Afnc )
C
C             where the NIUCON-by-NIUCON matrix Ainc is nonsingular and
C             upper triangular.
C             If JOBCON = 'I', Anc is nonsingular and upper triangular.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,N).
C
C     E       (input/output) DOUBLE PRECISION array, dimension (LDE,N)
C             On entry, the leading N-by-N part of this array must
C             contain the N-by-N descriptor matrix E.
C             On exit, the leading N-by-N part of this array contains
C             the transformed descriptor matrix Q'*E*Z,
C
C                                ( Ec   *  )
C                       Q'*E*Z = (         ) ,
C                                ( 0   Enc )
C
C             where Ec is NCONT-by-NCONT and Enc is
C             (N-NCONT)-by-(N-NCONT).
C             If JOBCON = 'C' or 'I', the matrix ( Bc Ec ) is in the
C             controllability staircase form (1).
C             If JOBCON = 'F', the submatrix Ec is upper triangular.
C             If JOBCON = 'C', the Enc matrix has the form
C
C                             ( Einc   *  )
C                       Enc = (           ) ,
C                             (  0   Efnc )
C
C             where the NIUCON-by-NIUCON matrix Einc is nilpotent
C             and the (N-NCONT-NIUCON)-by-(N-NCONT-NIUCON) matrix Efnc
C             is nonsingular and upper triangular.
C             If JOBCON = 'F', Enc is nonsingular and upper triangular.
C
C     LDE     INTEGER
C             The leading dimension of array E.  LDE >= MAX(1,N).
C
C     B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
C             On entry, the leading N-by-M part of this array must
C             contain the N-by-M input matrix B.
C             On exit, the leading N-by-M part of this array contains
C             the transformed input matrix
C
C                              ( Bc )
C                       Q'*B = (    ) ,
C                              ( 0  )
C
C              where Bc is NCONT-by-M.
C              For JOBCON = 'C' or 'I', the matrix ( Bc Ec ) is in the
C              controllability staircase form (1).
C              For JOBCON = 'F', the matrix ( Bc Ac ) is in the
C              controllability staircase form (3).
C
C     LDB     INTEGER
C             The leading dimension of array B.  LDB >= MAX(1,N).
C
C     C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
C             On entry, the leading P-by-N part of this array must
C             contain the state/output matrix C.
C             On exit, the leading P-by-N part of this array contains
C             the transformed matrix C*Z.
C
C     LDC     INTEGER
C             The leading dimension of array C.  LDC >= MAX(1,P).
C
C     Q       (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
C             If COMPQ = 'N': Q is not referenced.
C             If COMPQ = 'I': on entry, Q need not be set;
C                             on exit, the leading N-by-N part of this
C                             array contains the orthogonal matrix Q,
C                             where Q' is the product of transformations
C                             which are applied to A, E, and B on
C                             the left.
C             If COMPQ = 'U': on entry, the leading N-by-N part of this
C                             array must contain an orthogonal matrix
C                             Qc;
C                             on exit, the leading N-by-N part of this
C                             array contains the orthogonal matrix
C                             Qc*Q.
C
C     LDQ     INTEGER
C             The leading dimension of array Q.
C             LDQ >= 1,        if COMPQ = 'N';
C             LDQ >= MAX(1,N), if COMPQ = 'U' or 'I'.
C
C     Z       (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
C             If COMPZ = 'N': Z is not referenced.
C             If COMPZ = 'I': on entry, Z need not be set;
C                             on exit, the leading N-by-N part of this
C                             array contains the orthogonal matrix Z,
C                             which is the product of transformations
C                             applied to A, E, and C on the right.
C             If COMPZ = 'U': on entry, the leading N-by-N part of this
C                             array must contain an orthogonal matrix
C                             Zc;
C                             on exit, the leading N-by-N part of this
C                             array contains the orthogonal matrix
C                             Zc*Z.
C
C     LDZ     INTEGER
C             The leading dimension of array Z.
C             LDZ >= 1,        if COMPZ = 'N';
C             LDZ >= MAX(1,N), if COMPZ = 'U' or 'I'.
C
C     NCONT   (output) INTEGER
C             The order of the reduced matrices Ac and Ec, and the
C             number of rows of reduced matrix Bc; also the order of
C             the controllable part of the pair (A-lambda*E,B).
C
C     NIUCON  (output) INTEGER
C             For JOBCON = 'C', the order of the reduced matrices
C             Ainc and Einc; also the number of uncontrollable
C             infinite eigenvalues of the pencil A - lambda*E.
C             For JOBCON = 'F' or 'I', NIUCON has no significance
C             and is set to zero.
C
C     NRBLCK  (output) INTEGER
C             For JOBCON = 'C' or 'I', the number k, of full row rank
C                    _
C             blocks Ei,i in the staircase form of the pencil
C             (Bc Ec-lambda*Ac) (see (1) and (2)).
C             For JOBCON = 'F', the number k, of full row rank blocks
C             _
C             Ai,i in the staircase form of the pencil (Bc Ac-lambda*Ec)
C             (see (3) and (4)).
C
C     RTAU    (output) INTEGER array, dimension (N)
C             RTAU(i), for i = 1, ..., NRBLCK, is the row dimension of
C                                     _         _
C             the full row rank block Ei,i-1 or Ai,i-1 in the staircase
C             form (1) or (3) for JOBCON = 'C' or 'I', or
C             for JOBCON = 'F', respectively.
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             The tolerance to be used in rank determinations when
C             transforming (A-lambda*E, B). If the user sets TOL > 0,
C             then the given value of TOL is used as a lower bound for
C             reciprocal condition numbers in rank determinations; a
C             (sub)matrix whose estimated condition number is less than
C             1/TOL is considered to be of full rank.  If the user sets
C             TOL <= 0, then an implicitly computed, default tolerance,
C             defined by  TOLDEF = N*N*EPS,  is used instead, where EPS
C             is the machine precision (see LAPACK Library routine
C             DLAMCH).  TOL < 1.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (M)
C
C     DWORK   DOUBLE PRECISION array, dimension MAX(N,2*M)
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     The subroutine is based on the reduction algorithms of [1].
C
C     REFERENCES
C
C     [1] A. Varga
C         Computation of Irreducible Generalized State-Space
C         Realizations.
C         Kybernetika, vol. 26, pp. 89-106, 1990.
C
C     NUMERICAL ASPECTS
C
C     The algorithm is numerically backward stable and requires
C     0( N**3 )  floating point operations.
C
C     FURTHER COMMENTS
C
C     If the system matrices A, E and B are badly scaled, it is
C     generally recommendable to scale them with the SLICOT routine
C     TG01AD, before calling TG01HD.
C
C     CONTRIBUTOR
C
C     C. Oara, University "Politehnica" Bucharest.
C     A. Varga, German Aerospace Center, DLR Oberpfaffenhofen.
C     March 1999. Based on the RASP routine RPDSCF.
C
C     REVISIONS
C
C     July 1999, V. Sima, Research Institute for Informatics, Bucharest.
C
C     KEYWORDS
C
C     Controllability, minimal realization, orthogonal canonical form,
C     orthogonal transformation.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER          COMPQ, COMPZ, JOBCON
      INTEGER            INFO, LDA, LDB, LDC, LDE, LDQ, LDZ,
     $                   M, N, NCONT, NIUCON, NRBLCK, P
      DOUBLE PRECISION   TOL
C     .. Array Arguments ..
      INTEGER            IWORK( * ), RTAU( * )
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), C( LDC, *  ),
     $                   DWORK( * ),  E( LDE, * ), Q( LDQ, * ),
     $                   Z( LDZ, * )
C     .. Local Scalars ..
      CHARACTER          JOBQ, JOBZ
      LOGICAL            FINCON, ILQ, ILZ, INFCON
      INTEGER            ICOMPQ, ICOMPZ, LBA, NR
C     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
C     .. External Subroutines ..
      EXTERNAL           TG01HX, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC          MAX
C
C     .. Executable Statements ..
C
C     Decode JOBCON.
C
      IF( LSAME( JOBCON, 'C' ) ) THEN
         FINCON = .TRUE.
         INFCON = .TRUE.
      ELSE IF( LSAME( JOBCON, 'F' ) ) THEN
         FINCON = .TRUE.
         INFCON = .FALSE.
      ELSE IF( LSAME( JOBCON, 'I' ) ) THEN
         FINCON = .FALSE.
         INFCON = .TRUE.
      ELSE
         FINCON = .FALSE.
         INFCON = .FALSE.
      END IF
C
C     Decode COMPQ.
C
      IF( LSAME( COMPQ, 'N' ) ) THEN
         ILQ = .FALSE.
         ICOMPQ = 1
      ELSE IF( LSAME( COMPQ, 'U' ) ) THEN
         ILQ = .TRUE.
         ICOMPQ = 2
      ELSE IF( LSAME( COMPQ, 'I' ) ) THEN
         ILQ = .TRUE.
         ICOMPQ = 3
      ELSE
         ICOMPQ = 0
      END IF
C
C     Decode COMPZ.
C
      IF( LSAME( COMPZ, 'N' ) ) THEN
         ILZ = .FALSE.
         ICOMPZ = 1
      ELSE IF( LSAME( COMPZ, 'U' ) ) THEN
         ILZ = .TRUE.
         ICOMPZ = 2
      ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
         ILZ = .TRUE.
         ICOMPZ = 3
      ELSE
         ICOMPZ = 0
      END IF
C
C     Test the input scalar parameters.
C
      INFO = 0
      IF( .NOT.FINCON .AND. .NOT.INFCON ) THEN
         INFO = -1
      ELSE IF( ICOMPQ.LE.0 ) THEN
         INFO = -2
      ELSE IF( ICOMPZ.LE.0 ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( M.LT.0 ) THEN
         INFO = -5
      ELSE IF( P.LT.0 ) THEN
         INFO = -6
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -8
      ELSE IF( LDE.LT.MAX( 1, N ) ) THEN
         INFO = -10
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -12
      ELSE IF( LDC.LT.MAX( 1, P ) ) THEN
         INFO = -14
      ELSE IF( ( ILQ .AND. LDQ.LT.N ) .OR. LDQ.LT.1 ) THEN
         INFO = -16
      ELSE IF( ( ILZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN
         INFO = -18
      ELSE IF( TOL.GE.ONE ) THEN
         INFO = -23
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'TG01HD', -INFO )
         RETURN
      END IF
C
      JOBQ = COMPQ
      JOBZ = COMPZ
C
      IF( FINCON ) THEN
C
C        Perform finite controllability form reduction.
C
         CALL TG01HX( JOBQ, JOBZ, N, N, M, P, N, MAX( 0, N-1 ), A, LDA,
     $                E, LDE, B, LDB, C, LDC, Q, LDQ, Z, LDZ, NR,
     $                NRBLCK, RTAU, TOL, IWORK, DWORK, INFO )
         IF( NRBLCK.GT.1 ) THEN
            LBA = RTAU(1) + RTAU(2) - 1
         ELSE IF( NRBLCK.EQ.1 ) THEN
            LBA = RTAU(1) - 1
         ELSE
            LBA = 0
         END IF
         IF( ILQ ) JOBQ = 'U'
         IF( ILZ ) JOBZ = 'U'
      ELSE
         NR = N
         LBA = MAX( 0, N-1 )
      END IF
C
      IF( INFCON ) THEN
C
C        Perform infinite controllability form reduction.
C
         CALL TG01HX( JOBQ, JOBZ, N, N, M, P, NR, LBA, E, LDE,
     $                A, LDA, B, LDB, C, LDC, Q, LDQ, Z, LDZ, NCONT,
     $                NRBLCK, RTAU, TOL, IWORK, DWORK, INFO )
         IF( FINCON ) THEN
            NIUCON = NR - NCONT
         ELSE
            NIUCON = 0
         END IF
      ELSE
         NCONT  = NR
         NIUCON = 0
      END IF
C
      RETURN
C
C *** Last line of TG01HD ***
      END


C      SUBROUTINE CVNMO(IT02,ISI,IX2V2,NSAMPS,IANSWS,ISI2,ISI3,SCALAR)
      SUBROUTINE CVNMO(I1,I2,I3,I4,I5,I6,I7,I8)
C    CVNMO CALCULATES NORMAL MOVEOUT FOR A CONSTANT VELOCITY USING THE AP.
C  ACTUALLY, IT CALCULATES AN ARRAY OF TX VALUES (INDEXES TO THE UNMOVEDOUT
C  TRACE) CORRESPONDING TO A UNIFORMLY INCREASING T0.
C
C    TX=(SQRT(T0**2+C)+SCALAR+SI/2)/SI
C  WHERE:
C   TX = 2 WAY TRAVEL TIME (AS INDEXES TO THE TRACE)
C   T0 = 2 WAY NORMAL INCIDENT TIME
C   C  = X**2/V**2
C   X  = SHOT TO RECEIVER DISTANCE
C   V  = THE CONSTANT VELOCITY
C   SI = THE SAMPLE INTERVAL
C  SCALAR - A SCALAR VALUE TO ADD BEFORE CONVERTING TO INDICES. THIS IS A
C           CONVENIENT WAY TO REMOVE THE DEEP WATER DELAY TIME AND ALSO
C           FIND THE BEGINNING OF THE WINDOW
C
C  METHOD:
C    1)  BUILD AN ARRAY OF T0**2 USING THE INITIAL T0**2 AND THE SAMPLE INTERVAL
C    2)  SQUARE T0
C    3)  ADD THE CONSTANT X**2/V**2
C    4)  TAKE THE SQUARE ROOT
C    5)  ADD THE SCALAR
C    6)  ADD HALF THE SAMPLE INTERVAL FOR ROUNDOFF
C    7)  DIVIDE BY THE SAMPLE INTERVAL TO CONVERT TO SAMPLES
cccccccC    8)  CONVERT SAMPLES TO INDEXES (32 BIT INTEGERS).
C
C  ARGUMENTS:
C    IT02   - THE AP ADDRESS OF THE INITIAL T0 VALUE.
C    ISI    - THE AP ADDRESS OF THE TIME INCREMENT BETWEEN SUCCESSIVE T0 VALUES.
C    IX2V2  - THE AP ADDRESS OF THE SQUARE OF THE RANGE DIVIDED BY THE CONSTANT
C             VELOCITY ((X**2)/(V**2)).
C    NSAMPS - THE NUMBER OF TX VALUES TO COMPUTE.
C    IANSWS - THE AP ADDRESS OF THE OUTPUT ARRAY OF TX.
C    ISI2   - THE AP ADDRESS OF THE SAMPLE INTERVAL, IN SECONDS.
C    ISI3   - THE AP ADDRESS OF HALF THE SAMPLE INTERVAL.
C    SCALAR - THE AP ADDRESS OF THE SCALAR VALUE TO ADD.
C
C  WRITTEN AND COPYRIGHTED BY:
C  PAUL HENKART, SCRIPPS INSTITUTION OF OCEANOGRAPHY, 25 MARCH 1981
C  ALL RIGHTS ARE RESERVED BY THE AUTHOR.  PERMISSION TO COPY OR REPRODUCE THIS
C  SUBROUTINE, BY COMPUTER OR OTHER MEANS, MAY BE OBTAINED ONLY FROM THE AUTHOR.
C
      IMPLICIT INTEGER (A-Z)
      IT02=I1
      ISI=I2
      IX2V2=I3
      NSAMPS=I4
      IANSWS=I5
      ISI2=I6
      ISI3=I7
      SCALAR=I8
      CALL VRAMP(IT02,ISI,IANSWS,1,NSAMPS)
      CALL VMUL(IANSWS,1,IANSWS,1,IANSWS,1,NSAMPS)
      CALL VSADD(IANSWS,1,IX2V2,IANSWS,1,NSAMPS)
      CALL VSQRT(IANSWS,1,IANSWS,1,NSAMPS)
      CALL VSADD(IANSWS,1,SCALAR,IANSWS,1,NSAMPS)
      CALL VSADD(IANSWS,1,ISI3,IANSWS,1,NSAMPS)
      CALL VDIV(ISI2,0,IANSWS,1,IANSWS,1,NSAMPS)
c      CALL VFIX32(IANSWS,1,IANSWS,1,NSAMPS)
      RETURN
      END


subroutine MakeGeoidGrid(geoid, cilm, lmax, r0pot, GM, PotRef, omega, r, gridtype, &
			order, nlat, nlong, interval, lmax_calc, a, f)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	This subrouine will calculate the height to an equipotential surface with
!	respect to a spherical reference radius R for a body rotating with angular rotation
!	rate OMEGA. This method uses a first-, second-, or third-order Taylor series expansion
!	of the potential, evaluated at radius R. The output gridype is specificied by GRIDTYPE,
!	which can be either Cartesian 2D, Guass-Legendre quadrature, or Driscoll and Healy.
!	If the optional parameters A and F are specified, the geoid will be referenced to a
!	flattened ellispoid with semimajor axis A and flattening F.
!
!	Note that this routine is only strictly valid when the geoid is above the surface!
!	To calculated the height of the geoid when it is below the surface, one would
!	need to know the density structure of the planet. Furthermore, the calculation of the
!	potential (and its derivatives) is only strictly valid when R lies above the maximum radius
!	of the planet.
!
!	Latitude is geocentric latitude.
!
!	Calling Parameters
!		IN
!			cilm		Spherical harmonic potential coefficients.
!			lmax		Maximum spherical harmonic degree. For gridtype=1, this
!					is simply the maximum degree used in evaluating the
!					spherical harmonic coefficients. For the other grids,
!					this sets the spacing of the output grid.
!			r0pot		Reference radius of the potential coefficients.
!			GM		GM associated with the potential coefficients.
!			PotRef		Reference potential of the geoid.
!			omega		Angular rotation rate used when calculating the geoid
!					on in the rotating coordinate system.
!			r		Reference sperical radius to calculate the geoid heights.
!			gridtype	1 = Gauss-Legendre quadrature grid corresponding to LMAX.
!					2 = N by N Driscoll and Healy grid corresponding to LMAX.
!					3 = N by 2N Driscoll and Healy grid corresponding to LMAX.
!					4 = 2D Cartesian using MakeGrid2D.
!			order 		Order of the Taylor expansion. Either 1, 2, or 3.
!		OUT
!			geoid		Gridded values of the geoid, in meters, referenced to the spherical
!					radius R.
!			nlat, nlong	Number of latitude and longitude points for the grid.
!		OPTIONAL, IN
!			interval	Grid spacing of the output grid in DEGREES. Used only when
!					GRIDTYPE = 1.
!			lmax_calc	For GRIDTYPE 2, 3, and 4, this specifies the maximum spherical
!					harmonic degree to evaluate the function to.
!			a		Semimajor axis of the reference flattened ellipsoid.
!			f		Flattening of the reference ellipsoid.
!
!
!
!	Dependencies :  MakeGrid2D, MakeGridGLQ, MakeGridDH, NGLQSH, PreCompute
!
!	Written by Mark Wieczorek (October 2005)
!
!	May 31, 2006 -  Modified so that the Condon-Shortley phase is never used, regardless of
!			what the default value of CSPHASE_DEFAULT is.
!	June 23, 2007 - Completely rewritten. Can now use 4 different types of grids, and expanded
!			to third order.
!	April 2009 -	Changed the order of the gridtypes
!
!	Copyright (c) 2005-2007, Mark A. Wieczorek
!	All rights reserved.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	use SHTOOLS, only: MakeGrid2D, MakeGridGLQ, MakeGridDH, NGLQSH, PreCompute

	implicit none

	real*8, intent(out) ::	geoid(:,:)
	real*8, intent(in) ::	cilm(:,:,:), r0pot, GM, r, PotRef, omega
	integer, intent(in) :: lmax, order, gridtype
	integer, intent(in), optional :: lmax_calc
	integer, intent(out) :: nlat, nlong
	real*8, intent(in), optional ::	interval, a, f
	real*8 ::	pi, r_ex, lat
	integer :: 	l, nlat1, nlong1, lmax_comp, astat, n, i, astat1, astat2
	real*8, allocatable :: grida(:,:), gridb(:,:), gridc(:,:), gridd(:,:), zero(:), w(:), qq(:,:), pp(:,:), uu(:,:), &
				cilm1(:,:,:), cilm2(:,:,:)

	if ( (present(f) .and. .not. present(a)) .or. (present(a) .and. .not. present(f)) ) then
		print*, "Error --- MakeGeoidGrid"
		print*, "Both F and A must be specified."
		print*, "A, ", present(a)
		print*, "F, ", present(f)
		stop
	endif

	if (gridtype < 1 .or. gridtype > 4) then
		print*, "Error --- MakeGeoidGrid"
		print*, "GRIDTYPE must be either (1) Cartesian 2D, (2) Gauss-Legendre quadrature,"
		print*, "(3) N by N Driscoll and Healy, or (4) N by 2N Driscoll and Healy."
		print*, "Input value = ", gridtype
		stop
	endif

	if (gridtype == 4 .and. .not. present(interval)) then
		print*, "Error --- MakeGeoidGrid"
		print*, "If GRIDTYPE = 4 (2D Cartesian), the optional parameter INTERVAL"
		print*, "must be specified."
		stop
	endif

	if (order > 3 .or. order < 1) then
		print*, "Error --- MakeGeoidGrid"
		print*, "ORDER must be 1, 2, or 3."
		stop
	endif

	if (gridtype == 1) then
		nlong = 2*lmax + 1
		nlat = NGLQSH(lmax)	! nlat = lmax+1
	elseif (gridtype == 2) then
		nlat = 2*lmax+2
		nlong = nlat
	elseif (gridtype == 3) then
		nlat = 2*lmax+2
		nlong = 2*nlat
	elseif (gridtype == 4) then
		nlat = 180.0/interval + 1
		nlong = 360./interval + 1
	endif

	if (size(geoid(:,1)) < nlat .or. size(geoid(1,:)) < nlong ) then
		print*, "Error --- MakeGeoidGrid"
		print*, "GEOID must be dimensioned as (180/INTERVAL+1, 360/INTERVAL+1) where INTERVAL is ", interval
		print*, "Input array has dimension ", size(geoid(:,1)), size(geoid(1,:))
		stop
	elseif (size(cilm(:,1,1)) < 2) then
		print*, "Error --- MakeGeoidGrid"
		print*, "CILM must be dimensioned as (2, *, *)."
		print*, "Input dimension is ", size(cilm(:,1,1)), size(cilm(1,:,1)), size(cilm(1,1,:))
		stop
	endif

	if (present(lmax_calc)) then
		lmax_comp = min(lmax, size(cilm(1,1,:))-1, size(cilm(1,:,1))-1, lmax_calc)
	else
		lmax_comp = min(lmax, size(cilm(1,1,:))-1, size(cilm(1,:,1))-1)
	endif

	if (gridtype == 1) then
		allocate(zero(lmax+1), stat = astat)
		if (astat /=0) then
			print*, "Error --- MakeGeoidGrid"
			print*, "Problem allocating array ZERO, ", astat
			stop
		endif
		allocate(w(lmax+1), stat = astat)
		if (astat /=0) then
			print*, "Error --- MakeGeoidGrid"
			print*, "Problem allocating array W, ", astat
			stop
		endif
		call PreCompute(lmax, zero, w, norm=1, csphase=1)
	endif

	allocate(cilm1(2,lmax+1,lmax+1), stat = astat1)
	allocate(cilm2(2,lmax+1,lmax+1), stat = astat2)
	if (astat1 /= 0 .or. astat2 /= 0) then
		print*, "Error --- MakeGeoidGrid"
		print*, "Problem allocating arrays CILM1 and CILM2", astat1, astat2
		stop
	endif

	pi = acos(-1.0d0)

	cilm1(1:2,1:lmax+1, 1:lmax+1) = cilm(1:2,1:lmax+1, 1:lmax+1)
	cilm1(1,1,1) = 1.0d0	! Make sure that the degree-0 term is included

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	!	Solve the equation a + b x + c x**2 + d x**3 = 0
	!	for each grid point.
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	! Create grid A.

	do l=0, lmax_comp
		cilm2(1:2,l+1,1:l+1) = (GM/r) * cilm1(1:2,l+1,1:l+1) * (r0pot/r)**l
	enddo
	! add rotation and subtract reference field
	cilm2(1,1,1) = cilm2(1,1,1) + (omega*r)**2 / 3.0d0 - PotRef
	cilm2(1,3,1) = cilm2(1,3,1) - (omega*r)**2 / (3.0d0*sqrt(5.0d0))

	allocate(grida(nlat, nlong), stat = astat)
	if (astat /= 0) then
		print*, "Error --- MakeGeoidGrid"
		print*, "Problem allocating array GRIDA", astat
		stop
	endif

	select case(gridtype)
		case(1); call MakeGridGLQ(grida, cilm2, lmax, zero=zero, norm=1, csphase=1, lmax_calc=lmax_comp)
		case(2); call MakeGridDH(grida, n, cilm2, lmax, norm=1, csphase=1, sampling=1, lmax_calc = lmax_comp)
		case(3); call MakeGridDH(grida, n, cilm2, lmax, norm=1, csphase=1, sampling=2, lmax_calc = lmax_comp)
		case(4); call MakeGrid2D(grida, cilm2, lmax_comp, interval, nlat1, nlong1, norm=1, csphase=1)
	end select

	! Create Grid B

	do l=0, lmax_comp
		cilm2(1:2,l+1,1:l+1) = -(GM/r**2) * dble(l+1) * cilm1(1:2,l+1,1:l+1) * (r0pot/r)**l
	enddo
	! add rotational terms
	cilm2(1,1,1) = cilm2(1,1,1) + 2.0d0 * r * omega**2 / 3.0d0
	cilm2(1,3,1) = cilm2(1,3,1) - 2.0d0 * r * omega**2 / (3.0d0*sqrt(5.0d0))

	allocate(gridb(nlat, nlong), stat = astat)
	if (astat /= 0) then
		print*, "Error --- MakeGeoidGrid"
		print*, "Problem allocating array GRIDB", astat
		stop
	endif
	select case(gridtype)
		case(1); call MakeGridGLQ(gridb, cilm2, lmax, zero=zero, norm=1, csphase=1, lmax_calc=lmax_comp)
		case(2); call MakeGridDH(gridb, n, cilm2, lmax, norm=1, csphase=1, sampling=1, lmax_calc = lmax_comp)
		case(3); call MakeGridDH(gridb, n, cilm2, lmax, norm=1, csphase=1, sampling=2, lmax_calc = lmax_comp)
		case(4); call MakeGrid2D(gridb, cilm2, lmax_comp, interval, nlat1, nlong1, norm=1, csphase=1)
	end select

	! Create Grid C

	if (order == 2 .or. order == 3) then

		do l=0, lmax_comp
			cilm2(1:2,l+1,1:l+1) = GM/(2.0d0*r**3) * dble(l+1) * dble(l+2) * cilm1(1:2,l+1,1:l+1) * (r0pot/r)**l
		enddo
		! add rotational terms
		cilm2(1,1,1) = cilm2(1,1,1) + omega**2 / 3.0d0
		cilm2(1,3,1) = cilm2(1,3,1) - omega**2 / (3.0d0*sqrt(5.0d0))

		allocate(gridc(nlat, nlong), stat = astat)
		if (astat /= 0) then
			print*, "Error --- MakeGeoidGrid"
			print*, "Problem allocating array GRIDC", astat
			stop
		endif

		select case(gridtype)
			case(1); call MakeGridGLQ(gridc, cilm2, lmax, zero=zero, norm=1, csphase=1, lmax_calc=lmax_comp)
			case(2); call MakeGridDH(gridc, n, cilm2, lmax, norm=1, csphase=1, sampling=1, lmax_calc = lmax_comp)
			case(3); call MakeGridDH(gridc, n, cilm2, lmax, norm=1, csphase=1, sampling=2, lmax_calc = lmax_comp)
			case(4); call MakeGrid2D(gridc, cilm2, lmax_comp, interval, nlat1, nlong1, norm=1, csphase=1)
		end select

	endif

	! Create Grid D

	if (order == 3) then

		do l=0, lmax_comp
			cilm2(1:2,l+1,1:l+1) = -GM/(6.0d0*r**4) * dble(l+1) * dble(l+2) * dble(l+3) * &
						cilm1(1:2,l+1,1:l+1) * (r0pot/r)**l
		enddo

		allocate(gridd(nlat, nlong), stat = astat)
		if (astat /= 0) then
			print*, "Error --- MakeGeoidGrid"
			print*, "Problem allocating array GRIDD", astat
			stop
		endif

		select case(gridtype)
			case(1); call MakeGridGLQ(gridd, cilm2, lmax, zero=zero, norm=1, csphase=1, lmax_calc=lmax_comp)
			case(2); call MakeGridDH(gridd, n, cilm2, lmax, norm=1, csphase=1, sampling=1, lmax_calc = lmax_comp)
			case(3); call MakeGridDH(gridd, n, cilm2, lmax, norm=1, csphase=1, sampling=2, lmax_calc = lmax_comp)
			case(4); call MakeGrid2D(gridd, cilm2, lmax_comp, interval, nlat1, nlong1, norm=1, csphase=1)
		end select

	endif

	! solve equation

	if (order == 1) then

		geoid(1:nlat,1:nlong) = -grida(1:nlat,1:nlong) / gridb(1:nlat,1:nlong)

	elseif (order == 2) then

		geoid(1:nlat, 1:nlong) = (-gridb(1:nlat, 1:nlong) - &
		 		sqrt(gridb(1:nlat, 1:nlong)**2 - 4.0d0*gridc(1:nlat,1:nlong) * &
				grida(1:nlat, 1:nlong)) ) / (2.0d0*gridc(1:nlat,1:nlong))

	elseif (order == 3) then
		allocate(qq(nlat, nlong), stat = astat)
		if (astat /= 0) then
			print*, "Error --- MakeGeoidGrid"
			print*, "Problem allocating array QQ", astat
			stop
		endif
		allocate(pp(nlat, nlong), stat = astat)
		if (astat /= 0) then
			print*, "Error --- MakeGeoidGrid"
			print*, "Problem allocating array PP", astat
			stop
		endif
		allocate(uu(nlat, nlong), stat = astat)
		if (astat /= 0) then
			print*, "Error --- MakeGeoidGrid"
			print*, "Problem allocating array UU", astat
			stop
		endif

		pp(1:nlat,1:nlong) = gridb(1:nlat,1:nlong)/gridd(1:nlat,1:nlong) - &
			((gridc(1:nlat,1:nlong)/gridd(1:nlat,1:nlong))**2) / 3.0d0
		qq = grida(1:nlat,1:nlong)/gridd(1:nlat,1:nlong) + &
			2.0d0*((gridc(1:nlat,1:nlong)/gridd(1:nlat,1:nlong))**3) / 27.0d0 - &
			9.0d0*gridc(1:nlat,1:nlong)*gridb(1:nlat,1:nlong)/(gridd(1:nlat,1:nlong)**2) / 27.0d0
		uu(1:nlat,1:nlong) = (qq(1:nlat,1:nlong)/2.0d0 + &
			sqrt((qq(1:nlat,1:nlong)**2)/4.0d0 + (pp(1:nlat,1:nlong)**3)/27.0d0) )**(1.0d0/3.0d0)
		geoid(1:nlat,1:nlong) = pp(1:nlat,1:nlong)/3.0d0/uu(1:nlat,1:nlong) - &
			uu(1:nlat,1:nlong) - gridc(1:nlat,1:nlong)/gridd(1:nlat,1:nlong)/3.0d0

		deallocate(qq)
		deallocate(pp)
		deallocate(uu)

	endif

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	!	Reference geoid to a flattened ellipsoid
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	if (present(a) .and. present(f)) then
		do i = 1, nlat

			if (gridtype == 4) then
				lat = 90.0d0 - dble(i-1)*interval
			elseif (gridtype == 1) then
				lat = asin(zero(i)) * 180.0d0 / pi
			elseif (gridtype == 2 .or. gridtype == 3) then
				lat = 90.0d0 - 180.0d0 * dble(i-1)/dble(nlat)
			endif

			r_ex = a**2 * (1.0d0 + tan(lat*pi/180.0d0)**2) / &
			(1.0d0  + tan(lat*pi/180.0d0)**2 / (1.0d0 - f)**2 )
			r_ex = sqrt(r_ex)

			geoid(i,1:nlong) = geoid(i,1:nlong) + r - r_ex
		enddo
	endif

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	!	Clean up
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	if (gridtype == 2) then
		deallocate(zero)
		deallocate(w)
	endif
	deallocate(grida)
	deallocate(gridb)
	if (order == 2) deallocate(gridc)
	if (order == 3) then
		deallocate(gridc)
		deallocate(gridd)
	endif

	deallocate(cilm1)
	deallocate(cilm2)

end subroutine MakeGeoidGrid


!-----------------------------------------------------------------------
!     Module:        beams3d_volume
!     Authors:       S. Lazerson (samuel.lazerson@ipp.mpg.de)
!     Date:          09/23/2020
!     Description:   This subroutine computes the plasma volume based
!                    on the background grid.
!-----------------------------------------------------------------------
      SUBROUTINE beams3d_volume
!-----------------------------------------------------------------------
!     Libraries
!-----------------------------------------------------------------------
      USE beams3d_grid
      USE beams3d_runtime, ONLY: pi2, handle_err, EZSPLINE_ERR
      IMPLICIT NONE

!-----------------------------------------------------------------------
!     Input Variables
!        NONE
!-----------------------------------------------------------------------

!-----------------------------------------------------------------------
!     Local Variables
!        i           Helper index
!-----------------------------------------------------------------------
      INTEGER ::  i, nfp, ns_local, ier
      REAL(rprec) :: dR, dZ, dphi, s1, s2, ds, a1, a2, detinv
      REAL(rprec), DIMENSION(4) :: fmat
      REAL(rprec), DIMENSION(4,4) :: A, B
      REAL(rprec), DIMENSION(:), ALLOCATABLE :: slocal, dVds, Vtemp
      REAL(rprec), DIMENSION(:,:,:), ALLOCATABLE :: dV3d, temp
!-----------------------------------------------------------------------
!     Begin Subroutine
!-----------------------------------------------------------------------

      ! Cylindrical coordinates dV=R*dR*dZ*dPHI
      ns_local = nr
      nfp = NINT(pi2/phimax)
      dR = (rmax-rmin)/nr
      dZ = (zmax-zmin)/nz
      dphi = (phimax-phimin)/nphi
      ALLOCATE(dV3d(nr,nphi,nz),temp(nr,nphi,nz))
      DO i = 1, nr
         dV3d(i,:,:) = raxis(i)*dR*dZ*dphi
      END DO

      ! Create an Saxis
      ALLOCATE(slocal(ns_local))
      DO i = 1, ns_local
         slocal(i) = REAL(i-1)/REAL(ns_local-1)
      END DO

      ! Calculated Volume profile
      ALLOCATE(Vtemp(ns_local))
      !PRINT *,'VOLUME'
      Vtemp = 0
      DO i = 2, ns_local
         s1 = slocal(i-1)
         s2 = slocal(i)
         ds   = s2-s1
         temp = 0
         WHERE(S_ARR<=s2) temp = dV3d
         Vtemp(i) = SUM(SUM(SUM(temp,DIM=3),DIM=2),DIM=1)*nfp
         !PRINT *,slocal(i),Vtemp(i)
      END DO
      DEALLOCATE(dV3d, temp)

      ! We fit a 3rd order polynomial to the volume
      ! f  = a0 + a1*s + a2*s*s + a3*s*s*s
      ! f' =      a1   + 2*a2*s + 3*a3*s*s
      i=2
      A(1,2) = slocal(i)
      fmat(1)   = Vtemp(i)
      i  = ns_local/4
      A(2,2) = slocal(i)
      fmat(2)   = Vtemp(i)
      i  = ns_local/2
      A(3,2) = slocal(i)
      fmat(3)   = Vtemp(i)
      i  = ns_local
      A(4,2) = slocal(i)
      fmat(4)   = Vtemp(i)
      A(:,1) = 1
      A(:,3) = A(:,2)*A(:,2)
      A(:,4) = A(:,2)*A(:,2)*A(:,2)
!      PRINT *,'MATRIX'
!      PRINT *,A
!      PRINT *,fmat

      detinv = &
      1/(A(1,1)*(A(2,2)*(A(3,3)*A(4,4)-A(3,4)*A(4,3))+A(2,3)*(A(3,4)*A(4,2)-A(3,2)*A(4,4))+A(2,4)*(A(3,2)*A(4,3)-A(3,3)*A(4,2)))&
       - A(1,2)*(A(2,1)*(A(3,3)*A(4,4)-A(3,4)*A(4,3))+A(2,3)*(A(3,4)*A(4,1)-A(3,1)*A(4,4))+A(2,4)*(A(3,1)*A(4,3)-A(3,3)*A(4,1)))&
       + A(1,3)*(A(2,1)*(A(3,2)*A(4,4)-A(3,4)*A(4,2))+A(2,2)*(A(3,4)*A(4,1)-A(3,1)*A(4,4))+A(2,4)*(A(3,1)*A(4,2)-A(3,2)*A(4,1)))&
       - A(1,4)*(A(2,1)*(A(3,2)*A(4,3)-A(3,3)*A(4,2))+A(2,2)*(A(3,3)*A(4,1)-A(3,1)*A(4,3))+A(2,3)*(A(3,1)*A(4,2)-A(3,2)*A(4,1))))

      B(1,1) = detinv*(A(2,2)*(A(3,3)*A(4,4)-A(3,4)*A(4,3))+A(2,3)*(A(3,4)*A(4,2)-A(3,2)*A(4,4))+A(2,4)*(A(3,2)*A(4,3)-A(3,3)*A(4,2)))
      B(2,1) = detinv*(A(2,1)*(A(3,4)*A(4,3)-A(3,3)*A(4,4))+A(2,3)*(A(3,1)*A(4,4)-A(3,4)*A(4,1))+A(2,4)*(A(3,3)*A(4,1)-A(3,1)*A(4,3)))
      B(3,1) = detinv*(A(2,1)*(A(3,2)*A(4,4)-A(3,4)*A(4,2))+A(2,2)*(A(3,4)*A(4,1)-A(3,1)*A(4,4))+A(2,4)*(A(3,1)*A(4,2)-A(3,2)*A(4,1)))
      B(4,1) = detinv*(A(2,1)*(A(3,3)*A(4,2)-A(3,2)*A(4,3))+A(2,2)*(A(3,1)*A(4,3)-A(3,3)*A(4,1))+A(2,3)*(A(3,2)*A(4,1)-A(3,1)*A(4,2)))
      B(1,2) = detinv*(A(1,2)*(A(3,4)*A(4,3)-A(3,3)*A(4,4))+A(1,3)*(A(3,2)*A(4,4)-A(3,4)*A(4,2))+A(1,4)*(A(3,3)*A(4,2)-A(3,2)*A(4,3)))
      B(2,2) = detinv*(A(1,1)*(A(3,3)*A(4,4)-A(3,4)*A(4,3))+A(1,3)*(A(3,4)*A(4,1)-A(3,1)*A(4,4))+A(1,4)*(A(3,1)*A(4,3)-A(3,3)*A(4,1)))
      B(3,2) = detinv*(A(1,1)*(A(3,4)*A(4,2)-A(3,2)*A(4,4))+A(1,2)*(A(3,1)*A(4,4)-A(3,4)*A(4,1))+A(1,4)*(A(3,2)*A(4,1)-A(3,1)*A(4,2)))
      B(4,2) = detinv*(A(1,1)*(A(3,2)*A(4,3)-A(3,3)*A(4,2))+A(1,2)*(A(3,3)*A(4,1)-A(3,1)*A(4,3))+A(1,3)*(A(3,1)*A(4,2)-A(3,2)*A(4,1)))
      B(1,3) = detinv*(A(1,2)*(A(2,3)*A(4,4)-A(2,4)*A(4,3))+A(1,3)*(A(2,4)*A(4,2)-A(2,2)*A(4,4))+A(1,4)*(A(2,2)*A(4,3)-A(2,3)*A(4,2)))
      B(2,3) = detinv*(A(1,1)*(A(2,4)*A(4,3)-A(2,3)*A(4,4))+A(1,3)*(A(2,1)*A(4,4)-A(2,4)*A(4,1))+A(1,4)*(A(2,3)*A(4,1)-A(2,1)*A(4,3)))
      B(3,3) = detinv*(A(1,1)*(A(2,2)*A(4,4)-A(2,4)*A(4,2))+A(1,2)*(A(2,4)*A(4,1)-A(2,1)*A(4,4))+A(1,4)*(A(2,1)*A(4,2)-A(2,2)*A(4,1)))
      B(4,3) = detinv*(A(1,1)*(A(2,3)*A(4,2)-A(2,2)*A(4,3))+A(1,2)*(A(2,1)*A(4,3)-A(2,3)*A(4,1))+A(1,3)*(A(2,2)*A(4,1)-A(2,1)*A(4,2)))
      B(1,4) = detinv*(A(1,2)*(A(2,4)*A(3,3)-A(2,3)*A(3,4))+A(1,3)*(A(2,2)*A(3,4)-A(2,4)*A(3,2))+A(1,4)*(A(2,3)*A(3,2)-A(2,2)*A(3,3)))
      B(2,4) = detinv*(A(1,1)*(A(2,3)*A(3,4)-A(2,4)*A(3,3))+A(1,3)*(A(2,4)*A(3,1)-A(2,1)*A(3,4))+A(1,4)*(A(2,1)*A(3,3)-A(2,3)*A(3,1)))
      B(3,4) = detinv*(A(1,1)*(A(2,4)*A(3,2)-A(2,2)*A(3,4))+A(1,2)*(A(2,1)*A(3,4)-A(2,4)*A(3,1))+A(1,4)*(A(2,2)*A(3,1)-A(2,1)*A(3,2)))
      B(4,4) = detinv*(A(1,1)*(A(2,2)*A(3,3)-A(2,3)*A(3,2))+A(1,2)*(A(2,3)*A(3,1)-A(2,1)*A(3,3))+A(1,3)*(A(2,1)*A(3,2)-A(2,2)*A(3,1)))

      fmat=MATMUL(B,fmat)
      !PRINT *,'COEFS'
      !PRINT *,fmat
      DEALLOCATE(Vtemp)

      ! Now create functional form of dVds
      ALLOCATE(dVds(ns_local))
      dVds = 0
      dVds(1) = fmat(2)
      DO i = 2, ns_local
         s1 = REAL(i-1)/REAL(ns_local)
         s2 = REAL(i)/REAL(ns_local)
         ds   = s2-s1
         s1 = s1 + 0.5*ds
         dVds(i) = fmat(2) + 2*fmat(3)*s1 + 3*fmat(4)*s1*s1
      END DO

      ! TEST
      !PRINT *,'============'
      !DO i = 1, ns_local
      !   s1 = REAL(i-1)/REAL(ns_local)
      !   s2 = REAL(i)/REAL(ns_local)
      !   s1 = s1 + 0.5*(s2-s1)
      !   CALL EZspline_interp(Vp_spl_s,s1,ds,ier)
      !   PRINT *,i,dVds(i),ds
      !END DO

      IF (EZspline_allocated(Vp_spl_s))   CALL EZspline_free(Vp_spl_s,ier)
      !bcs1_s=(/ 0, 0 /)
      CALL EZspline_init(Vp_spl_s,ns_local,(/ 0, 0 /),ier)
      IF (ier /=0) CALL handle_err(EZSPLINE_ERR,'beams3d_volume',ier)
      Vp_spl_s%isHermite   = 1
      CALL EZspline_setup(Vp_spl_s,dVds,ier,EXACT_DIM=.true.)
      IF (ier /=0) CALL handle_err(EZSPLINE_ERR,'beams3d_volume',ier)

      RETURN
!-----------------------------------------------------------------------
!     END SUBROUTINE
!-----------------------------------------------------------------------
      END SUBROUTINE beams3d_volume


      SUBROUTINE RELAX2T
C
C CHANGE RECORD
C  ADDED THIS SUBROUTINE RELAX2T
C **  SUBROUTINE RELAX SOLVES THE FINITE DIFFERENCE FORM
C **  OF A PSEUDO HEMHOLTZ EQUATION
C **
C **              CS(L)*P(LS)+CW(L)*P(LWEST(L))
C **              +CC(L)*P(L)+CE(L)*P(LEAST(L))
C **
C **  BY SUCCESSIVE OVER RELAXATION USING A RED-BLACK ORDERING
C **  WITH CONVERGENCE MEASURED BY A GLOBAL SQUARE ERROR RSQ.
C **  NON-CONVERGENCE IS SIGNALED WHEN THE ITERATIONS EXCEED A
C **  MAXIMUM.
C
      USE GLOBAL
      RJ2=RP
C
C      PAVG=0.0
C
      FPSQ=0.
      DO L=2,LA
        FPSQ=FPSQ+FPTMP(L)*FPTMP(L)
      ENDDO
      ITER=1
  200 CONTINUE
      RSQ=0.
C
C **  RED CELL LOOP
C
      IF(ITER.EQ.1) RPT=1.0
      IF(ITER.GT.1) RPT=1.0/(1.0-0.25*RJ2*RPT)
      DO L=2,LA
        K=IL(L)+JL(L)
        IVAL=MOD(K,2)
        IF(IVAL.EQ.0)THEN
          LN=LNC(L)
          LS=LSC(L)
          RSD=CCC(L)*P(L)+CCS(L)*P(LS)+CCW(L)*P(LWEST(L))+CCE(L)*P(LEAST(L))
     &        +CCN(L)*P(LN)-FPTMP(L)
          P(L)=P(L)-RPT*RSD/CCC(L)
          RSQ=RSQ+RSD*RSD
        ENDIF
      ENDDO
C
C **  BLACK CELL LOOP
C
      IF(ITER.EQ.1) RPT=1.0/(1.0-0.5*RJ2)
      IF(ITER.GT.1) RPT=1.0/(1.0-0.25*RJ2*RPT)
      DO L=2,LA
        K=IL(L)+JL(L)
        IVAL=MOD(K,2)
        IF(IVAL.NE.0)THEN
          LN=LNC(L)
          LS=LSC(L)
          RSD=CCC(L)*P(L)+CCS(L)*P(LS)+CCW(L)*P(LWEST(L))+CCE(L)*P(LEAST(L))
     &        +CCN(L)*P(LN)-FPTMP(L)
          P(L)=P(L)-RPT*RSD/CCC(L)
          RSQ=RSQ+RSD*RSD
        ENDIF
      ENDDO
C
C **  CHECK SQUARED RESIDUAL CONVERGENCE CRITERIA
C
      RSQ=SQRT(RSQ)/SQRT(FPSQ)
      IF(RSQ .LE. RSQM) GOTO 400
C
C **  CHECK MAXIMUM ITERATION CRITERIA
C
      IF(ITER .GE. ITERM)THEN
        WRITE(6,600)
        WRITE(6,601)RSQ
        WRITE(8,600)
        WRITE(8,601)RSQ
        DO L=2,LA
          WRITE(8,800)L,CCS(L),CCW(L),CCC(L),CCE(L),CCN(L),P(L),FPTMP(L)
        ENDDO
        STOP
      ENDIF
      ITER=ITER+1
      GOTO 200
  400 CONTINUE
  600 FORMAT(' MAX ITERATIONS EXCEEDED IN EXTERNAL SOLUTION, RELAX2T')
  601 FORMAT(' RSQ = ',E14.5)
  800 FORMAT(I6,7E13.5)
      RETURN
      END


      INTEGER FUNCTION ISAMAX(N,X,INCX)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C>> 1994-11-11 ISAMAX  Krogh   Declared all vars.
C>> 1994-10-20 ISAMAX Krogh  Changes to use M77CON
C>> 1994-04-19 ISAMAX Krogh   Conveted to use generic intrinsics.
C>> 1987-12-09 ISAMAX Lawson  Initial code.
c--S replaces "?": I?AMAX
C
C     FIND SMALLEST INDEX OF MAXIMUM MAGNITUDE OF X.
C     ISAMAX =  FIRST I, I = 1 TO N, TO MINIMIZE  ABS(X(1-INCX+I*INCX))
C
      INTEGER N, INCX, NS, II, I
      REAL             X(*),XMAX,XMAG
      ISAMAX = 0
      IF(N.LE.0) RETURN
      ISAMAX = 1
      IF(N.LE.1)RETURN
      IF(INCX.EQ.1)GOTO 20
C
C        CODE FOR INCREMENTS NOT EQUAL TO 1.
C
      XMAX = ABS(X(1))
      NS = N*INCX
      II = 1
          DO 10 I = 1,NS,INCX
          XMAG = ABS(X(I))
          IF(XMAG.LE.XMAX) GO TO 5
          ISAMAX = II
          XMAX = XMAG
    5     II = II + 1
   10     CONTINUE
      RETURN
C
C        CODE FOR INCREMENTS EQUAL TO 1.
C
   20 XMAX = ABS(X(1))
      DO 30 I = 2,N
          XMAG = ABS(X(I))
          IF(XMAG.LE.XMAX) GO TO 30
          ISAMAX = I
          XMAX = XMAG
   30 CONTINUE
      RETURN
      END


** Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
** See https://llvm.org/LICENSE.txt for license information.
** SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception

*   Miscellaneous intrinsics which may appear in parameter statements

	program ff02
	complex c1, c2
	double complex cd1, cd2
	double precision d1, d2, d3, d4, d5, d6, d7, d8, d9
	character ch
	logical l1, l2, l3, l4

	parameter(N=40)

	integer result(N)
	integer expect(N)
	common result, expect

	parameter(i1 = abs(2.5))	! tests 1 - 2
	parameter(i2 = abs(-2.5))

	parameter(x1 = abs(2.5))	! tests 3 - 6
	parameter(x2 = abs(-4.5e+3))
	parameter(d1 = abs(2.5))
	parameter(d2 = abs(-5.4999d+4))
	parameter(i3 = nint(x1))
	parameter(i4 = nint(-x2))
	parameter(i5 = idnint(d1))
	parameter(i6 = idnint(-d2))

	parameter(c1 = (2.54, -4.89))	! tests 7-9
	parameter(c2 = conjg(c1))
	parameter(x3 = aimag(c2))

	parameter(cd1 = (4.49, -10.2))	! tests 10-12
	parameter(cd2 = conjg(c2))
	parameter(d3 = dimag(cd2))

	parameter(d4 = dprod(x1, x2))	! test 13

	parameter(i7 = max(i1, i2, i3, i4, i5, i6))	! tests 14-15
	parameter(i8 = min(i1, i2, i3, i4, i5, i6, i7))

	parameter(x4 = max(x1, x2, x3))			! tests 16-17
	parameter(x5 = min(x1, x2, x3, x4))

	parameter(d5 = max(d1, d2, d3, d4))		! tests 18-19
	parameter(d6 = min(d1, d2, d3, d4, d5))

	parameter(i9 = iand('aaaaaaaa'x, '84848484'x))	! tests 20-23
	parameter(i10 = ior('78787878'x, '87878787'x))
	parameter(i11 = not('f0f0f0f0'x))
	parameter(i12 = ieor('bbbbbbbb'x, '8af8afcd'x))

	parameter(i13 = mod(13, -3))			! tests 24-26
! the following tests are not constant folded yet; assignment
! statements are used instead
!	parameter(x6 = mod(-13.3, 5.0))
!	parameter(d7 = mod(15.3d+2, 1.53d+2))

	parameter(i14 = ichar('a'))			! test 27

	parameter(i15 = dim(20,15))			! tests 28-33
	parameter(i16 = dim(1,1))
	parameter(x7 = dim(20.0,15.0))
	parameter(x8 = dim(1.0,1.0))
	parameter(d8 = dim(20.0d+1, 15.0d+1))
	parameter(d9 = dim(1.0d+1, 1.0d+1))

	parameter(i17 = ishft('a0000000'x, 1))		! tests 34-35
	parameter(i18 = ishft('80000001'x, -1))

	parameter(ch = char(32))			! test 36

	parameter(l1 = lge('abcd', 'abcd'))		! tests 37-40
	parameter(l2 = lgt('abcd', 'abc'))
	parameter(l3 = lle('abc', 'abc'))
	parameter(l4 = llt('abc', 'abcd'))

	result(1) = i1
	result(2) = i2

	result(3) = i3
	result(4) = i4
	result(5) = i5
	result(6) = i6

	result(7) = c1
	result(8) = x3
	result(9) = cd1

	result(10) = cd1
	result(11) = d3
	result(12) = cd2

	result(13) = d4

	result(14) = i7
	result(15) = i8

	result(16) = x4
	result(17) = x5

	result(18) = d5
	result(19) = d6

	result(20) = i9
	result(21) = i10
	result(22) = i11
	result(23) = i12

	result(24) = i13
	x6 = mod(-13.3, 5.0)
	d7 = mod(15.3d+2, 1.53d+2)
	result(25) = x6
	result(26) = d7

	result(27) = i14

	result(28) = i15
	result(29) = i16
	result(30) = x7
	result(31) = x8
	result(32) = d8
	result(33) = d9

	result(34) = i17
	result(35) = i18

	result(36) = ichar(ch)

	result(37) = iand(l1, 1)
	result(38) = iand(l2, 1)
	result(39) = iand(l3, 1)
	result(40) = iand(l4, 1)

	call check(result, expect, N)
	data result/N*-99/
	data expect/
     + 2, 2,					! tests 1 - 2
     + 3, -4500, 3, -54999,			! tests 3 - 6
     + 2, 4, 4,					! tests 7-9
     + 4, -4, 2,				! tests 10-12
     + 11250,					! test 13
     + 3, -54999,				! tests 14-15
     + 4500, 2,					! tests 16-17
     + 54999, -4,				! tests 18-19
     + -2139062144, -1, 252645135, 826479734,	! tests 20-23
     + 1, -3, 0,				! tests 24-26
     + 97,					! test 27
     + 5, 0, 5, 0, 50, 0,			! tests 28-33
     + 1073741824, 1073741824,			! tests 34-35
     + 32,					! test 36
     + 1, 1, 1, 1 /				! tests 37-40
	end


module incidence_structure
  use utils
  use mtmod

  implicit none

  type IncidenceStructure
     integer, dimension(:,:), allocatable:: incidences
     integer, dimension(:,:), allocatable:: row_intersection
     integer, dimension(:,:), allocatable:: col_intersection
     integer, dimension(:), allocatable:: sum_in_row
     integer, dimension(:), allocatable:: sum_in_col
     integer v
     integer r
     integer k
     integer b
     integer lambda

     ! Heuristic helper vals, computed in the construct method
     integer sum_total
     integer sum_ideal
     integer heuristic_distance
     integer max_heuristic_distance
     integer min_useful_heuristic

     integer generations
  end type IncidenceStructure

contains

  subroutine construct(IS,v,k,lmbd)
    type(IncidenceStructure) IS
    integer v,k,lmbd
    real r_r, b_r
    integer i,j

    is%v=v
    is%k=k
    is%lambda=lmbd

    ! Test for neccessary BIBD conditions
    r_r=is%lambda*(is%v-1)/(is%k-1)
    b_r=r_r*is%v/is%k

    if (r_r/=int(r_r).or.b_r/=int(b_r)) then
       write (*,*) "Invalid BIBD parameters."
       stop
    else
       is%r=int(r_r)
       is%b=int(b_r)
       print *, "(v,k,λ,b,r) = ", is%v,is%k,is%lambda,is%b,is%r
    endif

    allocate(is%incidences(1:is%v,1:is%b))
    allocate(is%row_intersection(1:is%v,1:is%v))
    allocate(is%col_intersection(1:is%b,1:is%b))
    allocate(is%sum_in_row(1:is%v))
    allocate(is%sum_in_col(1:is%b))

    is%incidences(1:is%v,1:is%b)=0
    is%row_intersection(1:is%v,1:is%v)=0
    is%col_intersection(1:is%b,1:is%b)=0
    is%sum_in_row(1:is%v)=0
    is%sum_in_col(1:is%b)=0
    is%sum_total=0

    is%sum_ideal=is%k*is%b
    is%generations=0

    call updateCache(IS)
  end subroutine construct

  subroutine updateCache(IS)
    type(IncidenceStructure) IS

    integer i,j

    do i=1,is%v
       is%sum_in_row(i)=sum(is%incidences(i,:))
    enddo

    do j=1,is%b
       is%sum_in_col(j)=sum(is%incidences(:,j))
    enddo

    do i=1,is%v
       do j=1,is%v
          is%row_intersection(i,j)=dot_product(is%incidences(i,:), is%incidences(j,:))
       enddo
    enddo

    do i=1,is%b
       do j=1,is%b
          is%col_intersection(i,j)=dot_product(is%incidences(:,i), is%incidences(:,j))
       enddo
    enddo

    is%sum_total=sum(is%sum_in_row(1:is%v))

    call calculateHeuristicDistance(IS)
  end subroutine updateCache

  subroutine deconstruct(IS)
    type(IncidenceStructure) IS
    deallocate(is%incidences)
    deallocate(is%row_intersection)
    deallocate(is%col_intersection)
    deallocate(is%sum_in_row)
    deallocate(is%sum_in_col)
  end subroutine deconstruct

  logical function active(IS,row,col)
    type(IncidenceStructure) IS
    integer row,col

    if(is%incidences(row,col) /= 0) then
       active=.True.
    else
       active=.False.
    endif

    return
  end function active

  logical function dormant(IS,row,col)
    type(IncidenceStructure) IS
    integer row,col

    if(is%incidences(row,col) /= 0) then
       dormant=.False.
    else
       dormant=.true.
    endif

    return
  end function dormant

  ! Flips a CA's cell value, and updates the sums and products
  subroutine flip (IS,row,col)

    type(IncidenceStructure) IS
    integer row,col
    integer otherRow,otherCol,newVal

    newVal=abs(is%incidences(row,col)-1)
    is%incidences(row,col)=newVal
    if (newVal==0) then
       call decrement(is%sum_total,1)
       call decrement(is%sum_in_row(row),1)
       call decrement(is%sum_in_col(col),1)
       call decrement(is%row_intersection(row,row),1)
       call decrement(is%col_intersection(col,col),1)
    endif
    if (newVal==1) then
       call increment(is%sum_total,1)
       call increment(is%sum_in_row(row),1)
       call increment(is%sum_in_col(col),1)
       call increment(is%row_intersection(row,row),1)
       call increment(is%col_intersection(col,col),1)
    endif

    do otherRow=1,is%v
       if(is%incidences(otherRow,col)==1) then
          if(newVal==0) then
             call decrement(is%row_intersection(otherRow,row),1)
             call decrement(is%row_intersection(row,otherRow),1)
          endif
          if(newVal==1) then
             call increment(is%row_intersection(otherRow,row),1)
             call increment(is%row_intersection(row,otherRow),1)
          endif
       endif
    enddo

    do otherCol=1,is%b
       if(is%incidences(row,otherCol)==1) then
          if(newVal==0) then
             call decrement(is%col_intersection(otherCol,col),1)
             call decrement(is%col_intersection(col,otherCol),1)
          endif
          if(newVal==1) then
             call increment(is%col_intersection(otherCol,col),1)
             call increment(is%col_intersection(col,otherCol),1)
          endif
       endif
    enddo

    call calculateHeuristicDistance(IS)
  end subroutine flip

  subroutine calculateHeuristicDistance(IS)
    type(IncidenceStructure) IS

    integer i,j

    is%heuristic_distance = 0

    do i=1,is%b
       call increment(is%heuristic_distance,abs(is%sum_in_col(i) - is%k))
    enddo
    do i=1,is%v
       do j=1,is%v
          if(i==j) cycle
          call increment(is%heuristic_distance, abs(is%row_intersection(i,j) - is%lambda))
       enddo
    enddo
    is%max_heuristic_distance = is%b*(is%v - is%k) + (is%v**2 - is%v)*(is%r - is%lambda)
  end subroutine calculateHeuristicDistance

  !!***
  !! Checks if the incidence matrix with the other parameters is a BIBD
  !! Returns .True. if this is a 2-(v,k,λ) BIBD
  !! .False. otherwise
  logical function isBIBD(IS)

    type(IncidenceStructure) IS

    integer i,j

    ! if(is%heuristic_distance <= is%max_heuristic_distance ) then
    !      print *, "hd: ", is%max_heuristic_distance, "/", is%heuristic_distance
    !      call writeMatrix(IS)
    ! endif

    if(is%sum_total /= is%sum_ideal) then
       isBIBD=.False.
       !print *, "Sum is non-ideal", is%sum_total, is%sum_ideal
       return
    endif

    ! If the incidence matrix has a row with sum non-equal to r, this is not a BIBD
    do i=1,is%v
       if(is%sum_in_row(i)/=is%r) then
          isBIBD=.False.
          !print *, "Sum in row is non-ideal", is%sum_in_row(i), is%r
          return
       endif
    enddo

    ! If the incidence matrix has a row with sum non-equal to k, this is not a BIBD
    do i=1,is%b
       if(is%sum_in_col(i)/=is%k) then
          isBIBD=.False.
          !print *, "Sum in col is non-ideal", is%sum_in_col(i), is%k
          return
       endif
    enddo

    ! If there are two is%b (rows) whose intersection does not contain lambda is%v,
    ! this is not a BIBD
    do i=1,(is%v-1)
       do j=(i+1),is%v
          if (is%row_intersection(i,j)/=is%lambda) then
             isBIBD=.False.
             !print *, "Intersection is non-lambda", is%row_intersection(i,j)
             return
          endif
       enddo
    end do

    ! Otherwise, we got a BIBD
    isBIBD=.True.
    print *, "Generations: ", is%generations
    return
  end function isBIBD

  subroutine writeMatrix(IS)
    type(IncidenceStructure) IS
    integer row,col

    write(*,*),"["
    do row=1,is%v
       do col=1,is%b
          write (*,"(I1)",advance='no') is%incidences(row,col)
       enddo
       write (*,"(A1)",advance='no') "-"
       write (*,"(I1)",advance='no') is%sum_in_row(row)
       print *
    enddo
    do col=1,is%b
       write (*,"(A1)",advance='no') "|"
    enddo
    print *
    do col=1,is%b
       write (*,"(I1)",advance='no') is%sum_in_col(col)
    enddo
    print *
    write(*,*),"]"
  end subroutine writeMatrix
end module incidence_structure


!-----------------------------------------------------------------------
      program test

      include 'ceedf.h'

      integer ceed,err
      real*8 a(16), lambda(4)

      character arg*32

      a = (/ 0.2, 0.0745355993, -0.0745355993, 0.0333333333,&
     &       0.0745355993, 1., 0.1666666667, -0.0745355993,&
     &      -0.0745355993, 0.1666666667, 1., 0.0745355993,&
     &      0.0333333333, -0.0745355993, 0.0745355993, 0.2 /)

      call getarg(1,arg)

      call ceedinit(trim(arg)//char(0),ceed,err)
      call ceedsymmetricschurdecomposition(ceed,a,lambda,4,err);
      write (*,*) 'Q:'
      do i=0,3
        do j=1,4
          if (abs(a(i*4+j))<1.0D-14) then
! LCOV_EXCL_START
            a(i*4+j) = 0
! LCOV_EXCL_STOP
          endif
        enddo
        write(*,'(A,F12.8,F12.8,F12.8,F12.8)') '',&
     &   a(i*4+1),a(i*4+2),a(i*4+3),a(i*4+4)
      enddo
      write (*,*) 'lambda:'
      do i=1,4
        if (abs(lambda(i))<1.0D-14) then
! LCOV_EXCL_START
          lambda(i) = 0
! LCOV_EXCL_STOP
        endif
        write(*,'(A,F12.8)') '',lambda(i)
      enddo

      call ceeddestroy(ceed,err)

      end
!-----------------------------------------------------------------------