! cost averaging: self regulated step size
! reference: Sun and Szeto 2018: logit based transit assignment approachc based formulation and paradox
    module csramsolverlib
    use solverlib
    implicit none

    type,extends(methods)::csramsolver
    real*8::stepsize
    real*8::eta  ! greater than 1
    real*8::gama ! less than 1
    real*8,allocatable::c0(:)
    real*8,allocatable::c1(:)
    real*8,allocatable::h0(:)  !
    real*8,allocatable::h1(:)
    contains
        procedure,pass::solver=>solver
        procedure,pass::update_stepsize=>update_stepsize
        procedure,pass::ini=>ini
        procedure,pass::del=>del
        procedure,pass::get_load_prob=>get_load_prob
    end type csramsolver

    contains

    subroutine ini(this)
    use constpara
    implicit none
    class(csramsolver)::this
    this%name="CostAve"
    call this%inimethod
    allocate(this%c0(nl))
    this%c0=0
    allocate(this%c1(nl))
    this%c1=0
    allocate(this%h0(nl))
    this%h0=0
    allocate(this%h1(nl))
    this%h1=0
    end subroutine

    subroutine del(this)
    implicit none
    class(csramsolver)::this
    call this%delmethod
    deallocate(this%c0)
    deallocate(this%c1)
    deallocate(this%h0)
    deallocate(this%h1)
    end subroutine

    subroutine solver(this,large_step, small_step)
    use constpara
    implicit none
    real*8::norm_value
    real*8::iter
    real*8::large_step, small_step
    integer::subcounter
    reaL*8::et,cputime, time_end, time_begin
    real*8::fx(nl,ndest)
    real*8::x(nl,ndest)
    class(csramsolver):: this

    this%gapfileno = 98
    open (unit=this%gapfileno,file='c:\gitcodes\logitassign\results\csramgap.txt',&
         status='replace',action="write")
    write(this%gapfileno,*) 'solc,ncperr,disterr'

    call this%geninisol
    call cpu_time(time_begin)
    subcounter = 0

    ! this%ncperr = this%getncperr(this%x,this%xfa,this%fx,this%logitprob)

    iter = 1.0
    this%stepsize = 1.0
    this%eta = large_step
    this%gama = small_step

    this%c0 = this%nwk%scost
    this%h0 = this%lt - this%nwk%scost

    ! in the first iteratirion
5   if (iter.eq.1.0) then
        this%stepsize = this%stepsize + this%eta
    else
      call this%update_stepsize
    end if
    this%c1 = this%c0 + (1/this%stepsize)*this%h0
    this%lt = this%c1
    call this%backward_update_fx(this%fx,this%logitprob,d1=nl,d2=ndest)
    this%x = this%logitprob
    this%c0 =  this%c1
    call this%forward_update_flow(this%x,d1=nl,d2=ndest)
    call this%nwk%link_time(this%lf,this%c1)
    if (iter.gt.1.0) then
        this%h0 = this%h1
    end if
    this%h1 = this%c1- this%c0
    this%ncperr = this%getncperr(this%x,this%xfa,this%fx)
    ! write(*,*) norm_value(this%h1,nl),this%ncperr
    call cpu_time(time_end)
		cputime=time_end-time_begin

    if ((cputime.gt.maxcpu).or.(iter.gt.macsolc)) then
       close(1)
       close(this%gapfileno)
      return
    else
        iter = iter + 1
        go to 5
    end if
    close(1)
    close(this%gapfileno)
    return
    end subroutine

    subroutine update_stepsize(this)
    implicit none

    class(csramsolver)::this
    real*8::h0norm, h1norm
    reaL*8::norm_value
    h0norm = norm_value(this%h0,nl)
    h1norm= norm_value(this%h1,nl)
    if (h1norm.ge.h0norm) then
      this%stepsize = this%stepsize + this%eta
    else
      this%stepsize = this%stepsize + this%gama
    end if

    end subroutine

    subroutine get_load_prob(this)
    implicit none

    class(csramsolver)::this

    end subroutine

    end module


subroutine task_ranks

use grid
implicit none

integer i, j, i1, j1

!  "Coordinates" of the current subdomain:

j = rank/nsubdomains_x + 1
i = rank+1 - (j-1)*nsubdomains_x

!  Northen neighbour:

i1 = i
j1 = j + 1
if(j1.gt.nsubdomains_y) j1 = 1
ranknn = i1 + (j1-1)*nsubdomains_x - 1

!  North-Eastern neighbour:

i1 = i + 1
j1 = j + 1
if(j1.gt.nsubdomains_y) j1 = 1
if(i1.gt.nsubdomains_x) i1 = 1
rankne = i1 + (j1-1)*nsubdomains_x - 1

!  Eastern neighbour:

i1 = i + 1
j1 = j
if(i1.gt.nsubdomains_x) i1 = 1
rankee = i1 + (j1-1)*nsubdomains_x - 1

!  South-Eastern neighbour:

i1 = i + 1
j1 = j - 1
if(j1.lt.1) j1 = nsubdomains_y
if(i1.gt.nsubdomains_x) i1 = 1
rankse = i1 + (j1-1)*nsubdomains_x - 1

!  Southern neighbour:

i1 = i
j1 = j - 1
if(j1.lt.1) j1 = nsubdomains_y
rankss = i1 + (j1-1)*nsubdomains_x - 1

!  South-Western neighbour:

i1 = i - 1
j1 = j - 1
if(j1.lt.1) j1 = nsubdomains_y
if(i1.lt.1) i1 = nsubdomains_x
ranksw = i1 + (j1-1)*nsubdomains_x - 1

!  Western neighbour:

i1 = i - 1
j1 = j
if(i1.lt.1) i1 = nsubdomains_x
rankww = i1 + (j1-1)*nsubdomains_x - 1

!  North-Western neighbour:

i1 = i - 1
j1 = j + 1
if(j1.gt.nsubdomains_y) j1 = 1
if(i1.lt.1) i1 = nsubdomains_x
ranknw = i1 + (j1-1)*nsubdomains_x - 1

end


C HESSOL.F - Gateway function for analysing and solving a system of
C            linear equations with an upper Hessenberg coefficient
C            matrix using SLICOT routines MB02RD, MB02RZ, MB02SD,
C            MB02SZ, MB02TD, and MB02TZ.
C
C RELEASE 2.0 of SLICOT Basic Systems and Control Toolbox.
C Based on SLICOT RELEASE 5.7. Copyright (c) 2002-2020 NICONET e.V.
C
C Matlab call:
C   [(X)(,rcnd,LU,ipiv,Hn)] = Hessol(job,H(,ipiv,Hn,mtype,normh,B,tran))
C
C   [rcnd]                = Hessol(-2,LU,ipiv,Hn(,mtype,normh))
C   [X]                   = Hessol(-1,LU,ipiv,mtype,B(,tran))
C   [LU,ipiv(,Hn)]        = Hessol( 0,H(,mtype,normh))
C   [X(,LU,ipiv,Hn)]      = Hessol( 1,H,mtype,normh,B(,tran))
C   [rcnd(,LU,ipiv,Hn)]   = Hessol( 2,H(,mtype,normh))
C   [X,rcnd(,LU,ipiv,Hn)] = Hessol( 3,H,mtype,normh,B(,tran))
C
C Purpose:
C  To perform analysis and solution of a system of linear equations
C     H * X = B,  H' * X = B  or  H**H * X = B,
C  with a real or complex upper Hessenberg coefficient matrix H.
C  An LU factorization with row pivoting, H = P*L*U, is used, where
C  P is a permutation matrix, L is lower triangular with unit diagonal
C  elements (and one nonzero subdiagonal), and U is upper triangular.
C
C Input parameters:
C   job    - option parameter indicating the task to be performed.
C            =-2 :  condition estimation using LU factorization of H;
C            =-1 :  solution of the system using LU factorization of H;
C            = 0 :  LU factorization of H;
C            = 1 :  LU factorization of H and solution of the system;
C            = 2 :  LU factorization of H and condition estimation;
C            = 3 :  LU factorization of H, condition estimation, and
C                   solution of the system.
C   H      - the n-by-n Hessenberg matrix H or its LU factorization
C            (if job < 0).
C   ipiv   - (optional) if job < 0, the pivot indices defining P in the
C            LU factorization; for 1 <= i <= n, row i of the matrix H
C            was interchanged with row ipiv(i) of H.
C   Hn     - if job = -2, the 1-norm or the infinity-norm of the initial
C            matrix H, as specified by normh.
C   mtype  - (optional) option parameter indicating the type of the
C            matrix H.
C            = 0 :  real matrix;
C            = 1 :  complex matrix.
C            Default:  mtype = 0.
C   normh  - (optional) if job = -2, or job >= 0, specifies whether the
C            1-norm or the infinity-norm reciprocal condition number is
C            required.
C            = 1 :  1-norm;
C            = 2 :  infinity-norm.
C            Default:  normh = 1.
C   B      - (optional) if |job| = 1, or job = 3, the n-by-m matrix B.
C   tran   - (optional) if |job| = 1, or job = 3,  option parameter
C            indicating whether the matrix H or its (conjugate) transpose
C            should be used.
C            = 0 :  use the matrix H;
C            = 1 :  use the matrix H';
C            = 2 :  use the matrix H**H (if mtype = 1).
C            Default:  tran = 0.
C
C Output parameters:
C   X      - if |job| = 1, or job = 3, the n-by-m solution matrix.
C   rcnd   - if |job| = 2, or job = 3, the reciprocal of the condition
C            number of the matrix H, approximating (in the norm defined
C            by normh) 1/(norm(H) * norm(inv(H))).
C   LU     - if job >= 0, the n-by-n matrix containing the factors
C            L and U from the factorization H = P*L*U.
C   ipiv   - (optional) if job >= 0, the pivot indices defining P in the
C            LU factorization; for 1 <= i <= n, row i of the matrix H
C            was interchanged with row ipiv(i) of H.
C   Hn     - if job >= 0, the 1-norm or the infinity-norm of the initial
C            matrix H, as specified by normh.
C
C Contributor:
C   V. Sima, Research Institute for Informatics, Bucharest, Dec. 2002.
C
C Revisions:
C   V. Sima, Research Institute for Informatics, Bucharest, Jan. 2005,
C   Apr. 2009, Dec. 2012.
C
C **********************************************************************
C
      SUBROUTINE MEXFUNCTION( NLHS, PLHS, NRHS, PRHS )
C
C .. Parameters ..
      DOUBLE PRECISION  ZERO
      PARAMETER         ( ZERO = 0.0D0 )
C
C .. Mex-file interface parameters ..
      INTEGER           PLHS(*), PRHS(*)
      INTEGER*4         NLHS, NRHS
C
C .. Mex-file integer functions ..
      INTEGER           mxCreateDoubleMatrix, mxGetPi, mxGetPr
      INTEGER*4         mxGetM, mxGetN, mxIsNumeric, mxIsComplex
C
C .. Scalar parameters used by SLICOT subroutines ..
      CHARACTER         NORM, TRANS
      INTEGER           INFO, LDB, LDH, N, NRH
      DOUBLE PRECISION  HNORM, RCND
C
C .. Allocatable arrays ..
C !Fortran 90/95 (Fixed dimensions should be used with Fortran 77.)
      INTEGER,          ALLOCATABLE :: IPIV(:), IWORK(:)
      DOUBLE PRECISION, ALLOCATABLE :: B(:,:),  H(:,:),  DWORK(:)
      COMPLEX*16,       ALLOCATABLE :: BZ(:,:), HZ(:,:), ZWORK(:)
C
C .. Local variables and constant dimension arrays ..
      CHARACTER*120     TEXT
      LOGICAL           ICON, ISOL, ISREAL, SING
      INTEGER           I, IB, IJOB, INRM, IP, ITRAN, JOB, M, MB, MTYPE
      DOUBLE PRECISION  TEMP
C
C .. External functions ..
      INTEGER           IDAMAX, IZAMAX
      DOUBLE PRECISION  DLANHS, ZLANHS
      EXTERNAL          DLANHS, IDAMAX, IZAMAX, ZLANHS
C
C .. External subroutines ..
      EXTERNAL          MB02RD, MB02RZ, MB02SD, MB02SZ, MB02TD, MB02TZ
C
C .. Intrinsic functions ..
      INTRINSIC         ABS, MAX, MIN
C
C Check for proper number of arguments.
C
      IF ( NRHS.LT.2 ) THEN
         CALL mexErrMsgTxt
     $        ( 'HESSOL requires at least 2 input arguments' )
      ELSE IF ( NLHS.LT.1 ) THEN
         CALL mexErrMsgTxt
     $        ( 'HESSOL requires at least 1 output argument' )
      END IF
C
C   job, H(nxn), (ipiv(n), Hn, mtype, (normh,) B(nxm), tran).
C
      M = mxGetM( PRHS(2) )
      N = mxGetN( PRHS(2) )
C
      IF ( M.NE.N ) THEN
         CALL mexErrMsgTxt( 'H must be a square matrix' )
      END IF
C
      IF ( mxGetM( PRHS(1) ).NE.1 .OR.
     $     mxGetN( PRHS(1) ).NE.1 ) THEN
         CALL mexErrMsgTxt( 'JOB must be a scalar' )
      END IF
      IF ( mxIsNumeric( PRHS(1) ).EQ.0 .OR.
     $     mxIsComplex( PRHS(1) ).EQ.1 ) THEN
         CALL mexErrMsgTxt( 'JOB must be an integer scalar' )
      END IF
      CALL mxCopyPtrToReal8( mxGetPr( PRHS(1) ), TEMP, 1 )
      JOB  = TEMP
      IJOB = ABS( JOB )
      IF ( JOB.LT.-2 ) THEN
         CALL mexErrMsgTxt
     $           ( 'JOB must be larger than or equal to -2' )
      ELSE IF ( JOB.GT.3 ) THEN
         CALL mexErrMsgTxt
     $           ( 'JOB must be less than or equal to 3' )
      END IF
C
      IF ( ( JOB.EQ.3 .OR. JOB.EQ.0 ) .AND. NLHS.LT.2 ) THEN
         CALL mexErrMsgTxt
     $        ( 'HESSOL requires at least 2 output arguments' )
      END IF
C
      ISOL = IJOB.EQ.1 .OR. JOB.EQ.3
      ICON = IJOB.EQ.2 .OR. JOB.EQ.3
C
      IF ( JOB.LT.0 ) THEN
         IF ( JOB.EQ.-2 .AND. NRHS.LT.4 ) THEN
            CALL mexErrMsgTxt
     $           ( 'HESSOL requires at least 4 input arguments' )
         ELSE IF ( NRHS.LT.5 ) THEN
            CALL mexErrMsgTxt
     $           ( 'HESSOL requires at least 5 input arguments' )
         END IF
C
         IF ( mxIsNumeric( PRHS(3) ).EQ.0 .OR.
     $        mxIsComplex( PRHS(3) ).EQ.1 ) THEN
            CALL mexErrMsgTxt( 'IPIV must be an integer vector' )
         END IF
         MB = mxGetM( PRHS(3) )
         IB = mxGetN( PRHS(3) )
         IF ( MAX( MB, IB ).NE.N .AND.
     $        MIN( MB, IB ).NE.MIN( N, 1 ) ) THEN
            CALL mexErrMsgTxt
     $         ( 'IPIV must have the length equal to the order of H' )
         END IF
         IP = 4
C
         IF ( JOB.EQ.-2 ) THEN
C
C   Hn
C
            IF ( mxGetM( PRHS(IP) ).NE.1 .OR.
     $           mxGetN( PRHS(IP) ).NE.1 ) THEN
               CALL mexErrMsgTxt( 'HN must be a scalar' )
            END IF
            IF ( mxIsNumeric( PRHS(IP) ).EQ.0 .OR.
     $           mxIsComplex( PRHS(IP) ).EQ.1 ) THEN
               CALL mexErrMsgTxt( 'HN must be a real scalar' )
            END IF
            CALL mxCopyPtrToReal8( mxGetPr( PRHS(IP) ), HNORM, 1 )
            IF ( HNORM.LT.ZERO ) THEN
               CALL mexErrMsgTxt
     $            ( 'HN must be greater than or equal to zero' )
            END IF
            IP = IP + 1
         END IF
C
      ELSE
         IP = 3
      END IF
C
      IF ( NRHS.GE.IP ) THEN
C
C   mtype
C
         IF ( mxGetM( PRHS(IP) ).NE.1 .OR.
     $        mxGetN( PRHS(IP) ).NE.1 ) THEN
            CALL mexErrMsgTxt( 'MTYPE must be a scalar' )
         END IF
         IF ( mxIsNumeric( PRHS(IP) ).EQ.0 .OR.
     $        mxIsComplex( PRHS(IP) ).EQ.1 ) THEN
            CALL mexErrMsgTxt( 'MTYPE must be an integer scalar' )
         END IF
         CALL mxCopyPtrToReal8( mxGetPr( PRHS(IP) ), TEMP, 1 )
         MTYPE = TEMP
         IF ( MTYPE.LT.0 .OR. MTYPE.GT.1 ) THEN
            CALL mexErrMsgTxt
     $         ( 'MTYPE has 0 or 1 the only admissible values' )
         END IF
         IP = IP + 1
      ELSE
         MTYPE = 0
      END IF
      ISREAL = MTYPE.EQ.0
C
      IF ( mxIsNumeric( PRHS(2) ).EQ.0 )
     $   CALL mexErrMsgTxt( 'H must be a numeric matrix' )
      IF ( mxIsComplex( PRHS(2) ).EQ.1 .AND. ISREAL )
     $   CALL mexErrMsgTxt( 'H must be a real matrix' )
C
      IF ( ( JOB.GE.0 .OR. ICON ) .AND. NRHS.GE.IP ) THEN
C
C   normh
C
         IF ( mxGetM( PRHS(IP) ).NE.1 .OR.
     $        mxGetN( PRHS(IP) ).NE.1 ) THEN
            CALL mexErrMsgTxt( 'NORMH must be a scalar' )
         END IF
         IF ( mxIsNumeric( PRHS(IP) ).EQ.0 .OR.
     $        mxIsComplex( PRHS(IP) ).EQ.1 ) THEN
            CALL mexErrMsgTxt( 'NORMH must be an integer scalar' )
         END IF
         CALL mxCopyPtrToReal8( mxGetPr( PRHS(IP) ), TEMP, 1 )
         INRM = TEMP
         IF ( INRM.LT.1 .OR. INRM.GT.2 ) THEN
            CALL mexErrMsgTxt
     $         ( 'NORMH has 1 or 2 the only admissible values' )
         END IF
         IP = IP + 1
      ELSE
         INRM = 1
      END IF
C
      IF ( ISOL ) THEN
         IF ( NRHS.GE.IP ) THEN
C
C   B
C
            MB  = mxGetM( PRHS(IP) )
            NRH = mxGetN( PRHS(IP) )
C
            IF ( mxIsNumeric( PRHS(IP) ).EQ.0 )
     $         CALL mexErrMsgTxt( 'B must be a numeric matrix' )
            IF ( mxIsComplex( PRHS(IP) ).EQ.1 .AND. ISREAL )
     $         CALL mexErrMsgTxt( 'B must be a real matrix' )
            IF ( MB.NE.N ) THEN
               CALL mexErrMsgTxt( 'B must have the same row size as H' )
            END IF
            IB = IP
            IP = IP + 1
         ELSE
            CALL mexErrMsgTxt
     $           ( 'HESSOL requires at least 5 input arguments' )
         END IF
C
         IF ( NRHS.GE.IP ) THEN
C
C   tran
C
            IF ( mxGetM( PRHS(IP) ).NE.1 .OR.
     $           mxGetN( PRHS(IP) ).NE.1 ) THEN
               CALL mexErrMsgTxt( 'TRAN must be a scalar' )
            END IF
            IF ( mxIsNumeric( PRHS(IP) ).EQ.0 .OR.
     $           mxIsComplex( PRHS(IP) ).EQ.1 ) THEN
               CALL mexErrMsgTxt( 'TRAN must be an integer scalar' )
            END IF
            CALL mxCopyPtrToReal8( mxGetPr( PRHS(IP) ), TEMP, 1 )
            ITRAN = TEMP
            IF ( ITRAN.LT.0 .OR. ITRAN.GT.2 ) THEN
               CALL mexErrMsgTxt
     $            ( 'TRAN has 0, 1, or 2 the only admissible values' )
            END IF
         ELSE
            ITRAN = 0
         END IF
      END IF
C
      IF ( INRM.EQ.1 ) THEN
         NORM = '1'
      ELSE
         NORM = 'I'
      END IF
C
      IF ( ISOL ) THEN
         IF ( ITRAN.EQ.0 ) THEN
            TRANS = 'N'
         ELSE IF ( ITRAN.EQ.1 ) THEN
            TRANS = 'T'
         ELSE
            TRANS = 'C'
         END IF
      END IF
C
C Determine the lenghts of working arrays.
C
      LDH = MAX( 1, N )
      IF ( ISOL )
     $   LDB = LDH
C
C Allocate variable dimension local arrays.
C !Fortran 90/95
C
      ALLOCATE ( IPIV( N ) )
      IF ( ISREAL ) THEN
         ALLOCATE ( H( LDH, N ) )
         IF ( ISOL )
     $      ALLOCATE ( B( LDB, NRH ) )
         IF ( ICON )
     $      ALLOCATE ( DWORK( 3*N ), IWORK( N ) )
      ELSE
         ALLOCATE ( HZ( LDH, N ) )
         IF ( ISOL )
     $      ALLOCATE ( BZ( LDB, NRH ) )
         IF ( ICON )
     $      ALLOCATE ( DWORK( N ), ZWORK( 2*N ) )
      END IF
      IF ( .NOT.ICON )
     $   ALLOCATE ( DWORK( N ) )
C
C Copy inputs from MATLAB workspace to locally allocated arrays.
C
      IF ( ISREAL ) THEN
         CALL mxCopyPtrToReal8( mxGetPr( PRHS(2) ), H, N*N )
         IF ( ISOL )
     $      CALL mxCopyPtrToReal8( mxGetPr( PRHS(IB) ), B, N*NRH )
      ELSE
         CALL mxCopyPtrToComplex16( mxGetPr( PRHS(2) ),
     $                              mxGetPi( PRHS(2) ), HZ, N*N )
         IF ( ISOL )
     $      CALL mxCopyPtrToComplex16( mxGetPr( PRHS(IB) ),
     $                                 mxGetPi( PRHS(IB) ), BZ, N*NRH )
      END IF
      IF ( JOB.LT.0 ) THEN
         CALL mxCopyPtrToReal8( mxGetPr( PRHS(3) ), DWORK, N*MIN( N, 1 )
     $                        )
         DO 10 I = 1, N
            IPIV(I) = DWORK(I)
   10    CONTINUE
      END IF
C
C Do the actual computations.
C
      SING = .FALSE.
      IF ( JOB.GE.0 ) THEN
         IF ( ISREAL ) THEN
            HNORM = DLANHS( NORM, N, H, LDH, DWORK )
         ELSE
            HNORM = ZLANHS( NORM, N, HZ, LDH, DWORK )
         END IF
C
         IF ( ISREAL ) THEN
            CALL MB02SD( N, H, LDH, IPIV, INFO )
         ELSE
            CALL MB02SZ( N, HZ, LDH, IPIV, INFO )
         END IF
         IF ( INFO.NE.0 ) THEN
            RCND = ZERO
            SING = .TRUE.
         END IF
         IF ( .NOT.SING .AND. JOB.GT.0 ) THEN
            IF ( ISOL ) THEN
               IF ( ISREAL ) THEN
                  CALL MB02RD( TRANS, N, NRH, H, LDH, IPIV, B, LDB,
     $                         INFO )
               ELSE
                  CALL MB02RZ( TRANS, N, NRH, HZ, LDH, IPIV, BZ, LDB,
     $                         INFO )
               END IF
            END IF
            IF ( ICON ) THEN
               IF ( ISREAL ) THEN
                  CALL MB02TD( NORM, N, HNORM, H, LDH, IPIV, RCND,
     $                         IWORK, DWORK, INFO )
               ELSE
                  CALL MB02TZ( NORM, N, HNORM, HZ, LDH, IPIV, RCND,
     $                         DWORK, ZWORK, INFO )
               END IF
            END IF
         END IF
      ELSE IF ( ISOL ) THEN
         IF ( ISREAL ) THEN
            INFO = IDAMAX( N, H, LDH+1 )
            IF ( INFO.GT.0 ) THEN
               IF ( H(INFO,INFO).EQ.ZERO ) THEN
                  SING = .TRUE.
                  GO TO 30
               END IF
            END IF
            CALL MB02RD( TRANS, N, NRH, H, LDH, IPIV, B, LDB, INFO )
         ELSE
            INFO = IZAMAX( N, HZ, LDH+1 )
            IF ( INFO.GT.0 ) THEN
               IF ( ABS( HZ(INFO,INFO) ).EQ.ZERO ) THEN
                  SING = .TRUE.
                  GO TO 30
               END IF
            END IF
            CALL MB02RZ( TRANS, N, NRH, HZ, LDH, IPIV, BZ, LDB, INFO )
         END IF
      ELSE
         IF ( ISREAL ) THEN
            CALL MB02TD( NORM, N, HNORM, H, LDH, IPIV, RCND, IWORK,
     $                   DWORK, INFO )
         ELSE
            CALL MB02TZ( NORM, N, HNORM, HZ, LDH, IPIV, RCND, DWORK,
     $                   ZWORK, INFO )
         END IF
      END IF
C
C Copy output to MATLAB workspace.
C
      IP = 1
      IF ( ISOL .AND. .NOT.SING ) THEN
         IF ( ISREAL ) THEN
            PLHS(1) = mxCreateDoubleMatrix( N, NRH, 0 )
            CALL mxCopyReal8ToPtr( B, mxGetPr( PLHS(1) ), N*NRH )
         ELSE
            PLHS(1) = mxCreateDoubleMatrix( N, NRH, 1 )
            CALL mxCopyComplex16ToPtr( BZ, mxGetPr( PLHS(1) ),
     $                                 mxGetPi( PLHS(1) ), N*NRH )
         END IF
         IP = IP + 1
      END IF
      IF ( ( JOB.EQ.3 .AND. NLHS.GE.IP ) .OR. IJOB.EQ.2 ) THEN
         PLHS(IP) = mxCreateDoubleMatrix( 1, 1, 0 )
         CALL mxCopyReal8ToPtr( RCND, mxGetPr( PLHS(IP) ), 1 )
         IP = IP + 1
      END IF
      IF ( JOB.GE.0 .AND. NLHS.GE.IP ) THEN
         IF ( ISREAL ) THEN
            PLHS(IP) = mxCreateDoubleMatrix( N, N, 0 )
            CALL mxCopyReal8ToPtr( H, mxGetPr( PLHS(IP) ), N*N )
         ELSE
            PLHS(IP) = mxCreateDoubleMatrix( N, N, 1 )
            CALL mxCopyComplex16ToPtr( HZ, mxGetPr( PLHS(IP) ),
     $                                 mxGetPi( PLHS(IP) ), N*N )
         END IF
         IP = IP + 1
         IF ( NLHS.GE.IP ) THEN
            DO 20 I = 1, N
               DWORK(I) = IPIV(I)
   20       CONTINUE
            PLHS(IP) = mxCreateDoubleMatrix( N, MIN( N, 1 ), 0 )
            CALL mxCopyReal8ToPtr( DWORK, mxGetPr( PLHS(IP) ),
     $                             N*MIN( N, 1 ) )
            IP = IP + 1
         END IF
         IF ( NLHS.GE.IP ) THEN
            PLHS(IP) = mxCreateDoubleMatrix( 1, 1, 0 )
            CALL mxCopyReal8ToPtr( HNORM, mxGetPr( PLHS(IP) ), 1 )
         END IF
      END IF
C
C Deallocate local arrays.
C !Fortran 90/95
C
   30 CONTINUE
C
      DEALLOCATE ( IPIV )
      IF ( ISREAL ) THEN
         DEALLOCATE ( H )
         IF ( ISOL )
     $      DEALLOCATE ( B )
         IF ( ICON )
     $      DEALLOCATE ( DWORK, IWORK )
      ELSE
         DEALLOCATE ( HZ )
         IF ( ISOL )
     $      DEALLOCATE ( BZ )
         IF ( ICON )
     $      DEALLOCATE ( DWORK, ZWORK )
      END IF
      IF ( .NOT.ICON )
     $   DEALLOCATE ( DWORK )
C
C Error and warning handling.
C
      IF ( SING ) THEN
         WRITE( TEXT, '('' Warning: Matrix H is singular.'')' )
         CALL mexPrintf( TEXT )
         IF ( ISOL ) THEN
            WRITE( TEXT, '('' The solution is infinite.'')' )
            CALL mexErrMsgTxt( TEXT )
         END IF
      END IF
C
      RETURN
C *** Last line of HESSOL ***
      END


! { dg-do run }
! Tests dynamic dispatch of class subroutines.
!
! Contributed by Paul Thomas <pault@gcc.gnu.org>
!
module m
  type :: t1
    integer :: i = 42
    procedure(make_real), pointer :: ptr
  contains
    procedure, pass :: real => make_real
    procedure, pass :: make_integer
    procedure, pass :: prod => i_m_j
    generic, public :: extract => real, make_integer
  end type t1

  type, extends(t1) :: t2
    integer :: j = 99
  contains
    procedure, pass :: real => make_real2
    procedure, pass :: make_integer => make_integer_2
    procedure, pass :: prod => i_m_j_2
  end type t2
contains
  subroutine make_real (arg, arg2)
    class(t1), intent(in) :: arg
    real :: arg2
    arg2 = real (arg%i)
  end subroutine make_real

  subroutine make_real2 (arg, arg2)
    class(t2), intent(in) :: arg
    real :: arg2
    arg2 = real (arg%j)
  end subroutine make_real2

  subroutine make_integer (arg, arg2, arg3)
    class(t1), intent(in) :: arg
    integer :: arg2, arg3
    arg3 = arg%i * arg2
  end subroutine make_integer

  subroutine make_integer_2 (arg, arg2, arg3)
    class(t2), intent(in) :: arg
    integer :: arg2, arg3
    arg3 = arg%j * arg2
  end subroutine make_integer_2

  subroutine i_m_j (arg, arg2)
    class(t1), intent(in) :: arg
    integer :: arg2
        arg2 = arg%i
  end subroutine i_m_j

  subroutine i_m_j_2 (arg, arg2)
    class(t2), intent(in) :: arg
    integer :: arg2
        arg2 = arg%j
  end subroutine i_m_j_2
end module m

  use m
  type, extends(t1) :: l1
    character(16) :: chr
  end type l1
  class(t1), pointer :: a !=> NULL()
  type(t1), target :: b
  type(t2), target :: c
  type(l1), target :: d
  real :: r
  integer :: i

  a => b                                   ! declared type
  call a%real(r)
  if (r .ne. real (42)) call abort
  call a%prod(i)
  if (i .ne. 42) call abort
  call a%extract (2, i)
  if (i .ne. 84) call abort

  a => c                                   ! extension in module
  call a%real(r)
  if (r .ne. real (99)) call abort
  call a%prod(i)
  if (i .ne. 99) call abort
  call a%extract (3, i)
  if (i .ne. 297) call abort

  a => d                                   ! extension in main
  call a%real(r)
  if (r .ne. real (42)) call abort
  call a%prod(i)
  if (i .ne. 42) call abort
  call a%extract (4, i)
  if (i .ne. 168) call abort
end
! { dg-final { cleanup-modules "m" } }


! 1 dimension
program demo

    use ntree_factory_m, only: ntree_t, shape_t, make_boundary, make_ntree, make_range, point_t
    use queue_m, only: queue_t
    implicit none
    class(shape_t), allocatable :: boundary, range
    type (queue_t) :: found
    class(*), allocatable :: data
    type(point_t), allocatable :: point
    type (ntree_t) :: binarize_tree
    logical :: info
    integer :: i

    call make_boundary([0.0], [1.0], boundary, squared=.true.)
    call make_ntree(boundary, 2, binarize_tree)
    call binarize_tree%insert(point_t([0.5]), info)
    call binarize_tree%insert(point_t([-0.1]), info)
    call binarize_tree%insert(point_t([0.1]), info)
    call binarize_tree%insert(point_t([0.85]), info)
    call binarize_tree%insert(point_t([0.7]), info)
    call binarize_tree%insert(point_t([0.3]), info)
    call binarize_tree%insert(point_t([randu()]), info)
    call make_range([0.9], radius=0.3, range=range)
    call binarize_tree%query(range, found)

    if (found%size() == 0) stop
    do i = 1, found%size()
        call found%dequeue(data)
        point = to_point(data)
        write(*, '("x = [",f6.2,"] dist = ",f6.2)') point%x(1), abs(point%x(1) - 0.9)
    end do

contains

    function randu() result(r)
        real :: r
        call random_number(r)
    end function randu

    pure function to_point(x) result(p)
        class(*), intent(in) :: x
        type(point_t) :: p
        select type (x)
        type is (point_t)
            p = x
        end select
    end function to_point

end program demo


program ewald_convN

! Runs a benchmark with regards to the number of atoms N.

use types, only: dp
use ewald_sums, only: ewald_box, ewald_fft1, fred2fcart, min_distance
use md, only: positions_fcc
use utils, only: assert, init_random
implicit none

integer :: natom, ntypat

real(dp), parameter :: E_reference = -1.9853035145151909_dp
real(dp) :: stress(6)
real(dp), allocatable :: xred(:, :), forces(:, :), q(:)
real(dp) :: L, E_ewald, E_ewald_fft
real(dp) :: t1, t2, t3, t4
integer :: i, u

open(newunit=u, file="ewald_convN.txt", status="replace")

do i = 1, 6
    natom = 4*i**3
    ntypat = 1
    allocate(xred(3, natom), forces(3, natom), q(natom))
    call positions_fcc(xred, 1._dp)
    q = 1
    L = 2 / sqrt(3._dp)
    L = L * i
    print *, "half of xred min distance:", min_distance(xred*L, L)/2

    call cpu_time(t1)
    call ewald_box(L, xred*L, q, E_ewald, forces, stress)
    call cpu_time(t2)
    E_ewald = E_ewald / (natom/ntypat)

    call cpu_time(t3)
    call ewald_fft1(L, xred*L, q, 32*i, 0.40824_dp, E_ewald_fft)
    call cpu_time(t4)
    E_ewald_fft = E_ewald_fft / (natom/ntypat)
    print *, i, natom, t2-t1, t4-t3
    print *, E_ewald, E_ewald_fft
    print *, abs(E_ewald - E_reference), abs(E_ewald_fft-E_reference)
    write(u, *) i, natom, t2-t1, t4-t3, E_ewald, E_ewald_fft

    deallocate(xred, forces, q)
end do

close(u)

end program


      program test
         use minpack_module
      implicit none
!     **********
!
!     THIS PROGRAM TESTS CODES FOR THE LEAST-SQUARES SOLUTION OF
!     M NONLINEAR EQUATIONS IN N VARIABLES. IT CONSISTS OF A DRIVER
!     AND AN INTERFACE SUBROUTINE FCN. THE DRIVER READS IN DATA,
!     CALLS THE NONLINEAR LEAST-SQUARES SOLVER, AND FINALLY PRINTS
!     OUT INFORMATION ON THE PERFORMANCE OF THE SOLVER. THIS IS
!     ONLY A SAMPLE DRIVER, MANY OTHER DRIVERS ARE POSSIBLE. THE
!     INTERFACE SUBROUTINE FCN IS NECESSARY TO TAKE INTO ACCOUNT THE
!     FORMS OF CALLING SEQUENCES USED BY THE FUNCTION AND JACOBIAN
!     SUBROUTINES IN THE VARIOUS NONLINEAR LEAST-SQUARES SOLVERS.
!
!     SUBPROGRAMS CALLED
!
!       USER-SUPPLIED ...... FCN
!
!       MINPACK-SUPPLIED ... DPMPAR,ENORM,INITPT,LMSTR1,SSQFCN
!
!       FORTRAN-SUPPLIED ... sqrt
!
!     ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
!     BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
!
!     **********
      integer i , ic , info , k , ldfjac , lwa , m , n , NFEv , NJEv ,  &
            & NPRob , nread , ntries , nwrite
      integer iwa(40) , ma(60) , na(60) , nf(60) , nj(60) , np(60) ,    &
            & nx(60)
      double precision factor , fnorm1 , fnorm2 , one , ten , tol
      double precision fjac(40,40) , fnm(60) , fvec(65) , wa(265) ,     &
                     & x(40)
      external fcn

      integer,dimension(18),parameter :: m_array = [20,20,20,2,3,4,2,15,11,16,31,10,10,20,20,10,33,65]
      integer,dimension(18),parameter :: n_array = [10,10,10,2,3,4,2,3,4,3,9,3,2,4,10,10,5,11]

      common /refnum/ NPRob , NFEv , NJEv
!
!     LOGICAL INPUT UNIT IS ASSUMED TO BE NUMBER 5.
!     LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6.
!
      data nread , nwrite/5 , 6/
!
      data one , ten/1.0d0 , 1.0d1/
      tol = sqrt(dpmpar(1))
      ldfjac = 40
      lwa = 265
      ic = 0
      ntries = 1
      do NPRob = 1, 19
!  100  read (nread,99001) NPRob , n , m , ntries
! 99001 format (4i5)
      if ( NPRob==19 ) then
         write (nwrite,99002) ic
99002    format ('1SUMMARY OF ',i3,' CALLS TO LMSTR1'/)
         write (nwrite,99003)
99003    format (' NPROB   N    M   NFEV  NJEV  INFO  FINAL L2 NORM'/)
         do i = 1 , ic
            write (nwrite,99004) np(i) , na(i) , ma(i) , nf(i) , nj(i) ,&
                               & nx(i) , fnm(i)
99004       format (3i5,3i6,1x,d15.7)
         enddo
         stop
      else
         n = n_array(NPRob)
         m = m_array(NPRob)
         factor = one
         do k = 1 , ntries
            ic = ic + 1
            call initpt(n,x,NPRob,factor)
            call ssqfcn(m,n,x,fvec,NPRob)
            fnorm1 = enorm(m,fvec)
            write (nwrite,99005) NPRob , n , m
99005       format (////5x,' PROBLEM',i5,5x,' DIMENSIONS',2i5,5x//)
            NFEv = 0
            NJEv = 0
            call lmstr1(fcn,m,n,x,fvec,fjac,ldfjac,tol,info,iwa,wa,lwa)
            call ssqfcn(m,n,x,fvec,NPRob)
            fnorm2 = enorm(m,fvec)
            np(ic) = NPRob
            na(ic) = n
            ma(ic) = m
            nf(ic) = NFEv
            nj(ic) = NJEv
            nx(ic) = info
            fnm(ic) = fnorm2
            write (nwrite,99006) fnorm1 , fnorm2 , NFEv , NJEv , info , &
                               & (x(i),i=1,n)
99006       format (5x,' INITIAL L2 NORM OF THE RESIDUALS',d15.7//5x,   &
                   &' FINAL L2 NORM OF THE RESIDUALS  ',d15.7//5x,      &
                   &' NUMBER OF FUNCTION EVALUATIONS  ',i10//5x,        &
                   &' NUMBER OF JACOBIAN EVALUATIONS  ',i10//5x,        &
                   &' EXIT PARAMETER',18x,i10//5x,                      &
                   &' FINAL APPROXIMATE SOLUTION'//(5x,5d15.7))
            factor = ten*factor
         enddo
      endif
      end do

   end program test

      subroutine fcn(m,n,x,Fvec,Fjrow,Iflag)
      implicit none

      integer m , n , Iflag
      double precision x(n) , Fvec(m) , Fjrow(n)
!     **********
!
!     THE CALLING SEQUENCE OF FCN SHOULD BE IDENTICAL TO THE
!     CALLING SEQUENCE OF THE FUNCTION SUBROUTINE IN THE NONLINEAR
!     LEAST SQUARES SOLVER. IF IFLAG = 1, FCN SHOULD ONLY CALL THE
!     TESTING FUNCTION SUBROUTINE SSQFCN. IF IFLAG = I, I .GE. 2,
!     FCN SHOULD ONLY CALL SUBROUTINE SSQJAC TO CALCULATE THE
!     (I-1)-ST ROW OF THE JACOBIAN. (THE SSQJAC SUBROUTINE PROVIDED
!     HERE FOR TESTING PURPOSES CALCULATES THE ENTIRE JACOBIAN
!     MATRIX AND IS THEREFORE CALLED ONLY WHEN IFLAG = 2.) EACH
!     CALL TO SSQFCN OR SSQJAC SHOULD SPECIFY THE APPROPRIATE
!     VALUE OF PROBLEM NUMBER (NPROB).
!
!     SUBPROGRAMS CALLED
!
!       MINPACK-SUPPLIED ... SSQFCN,SSQJAC
!
!     ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
!     BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
!
!     **********
      integer NPRob , NFEv , NJEv , j
      double precision temp(65,40)
      common /refnum/ NPRob , NFEv , NJEv
      if ( Iflag==1 ) call ssqfcn(m,n,x,Fvec,NPRob)
      if ( Iflag==2 ) call ssqjac(m,n,x,temp,65,NPRob)
      if ( Iflag==1 ) NFEv = NFEv + 1
      if ( Iflag==2 ) NJEv = NJEv + 1
      if ( Iflag/=1 ) then
         do j = 1 , n
            Fjrow(j) = temp(Iflag-1,j)
         enddo
      endif
!
!     LAST CARD OF INTERFACE SUBROUTINE FCN.
!
      end

      subroutine ssqjac(m,n,x,Fjac,Ldfjac,Nprob)
      implicit none

      integer m , n , Ldfjac , Nprob
      double precision x(n) , Fjac(Ldfjac,n)
!     **********
!
!     SUBROUTINE SSQJAC
!
!     THIS SUBROUTINE DEFINES THE JACOBIAN MATRICES OF EIGHTEEN
!     NONLINEAR LEAST SQUARES PROBLEMS. THE PROBLEM DIMENSIONS ARE
!     AS DESCRIBED IN THE PROLOGUE COMMENTS OF SSQFCN.
!
!     THE SUBROUTINE STATEMENT IS
!
!       SUBROUTINE SSQJAC(M,N,X,FJAC,LDFJAC,NPROB)
!
!     WHERE
!
!       M AND N ARE POSITIVE INTEGER INPUT VARIABLES. N MUST NOT
!         EXCEED M.
!
!       X IS AN INPUT ARRAY OF LENGTH N.
!
!       FJAC IS AN M BY N OUTPUT ARRAY WHICH CONTAINS THE JACOBIAN
!         MATRIX OF THE NPROB FUNCTION EVALUATED AT X.
!
!       LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M
!         WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC.
!
!       NPROB IS A POSITIVE INTEGER VARIABLE WHICH DEFINES THE
!         NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 18.
!
!     SUBPROGRAMS CALLED
!
!       FORTRAN-SUPPLIED ... atan,cos,exp,sin,sqrt
!
!     ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
!     BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
!
!     **********
      integer i , ivar , j , k , mm1 , nm1
      double precision c14 , c20 , c29 , c45 , c100 , div , dx , eight ,&
                     & five , four , one , prod , s2 , temp , ten ,     &
                     & three , ti , tmp1 , tmp2 , tmp3 , tmp4 , tpi ,   &
                     & two , zero
      double precision v(11)
      double precision dfloat
      data zero , one , two , three , four , five , eight , ten , c14 , &
         & c20 , c29 , c45 , c100/0.0d0 , 1.0d0 , 2.0d0 , 3.0d0 ,       &
         & 4.0d0 , 5.0d0 , 8.0d0 , 1.0d1 , 1.4d1 , 2.0d1 , 2.9d1 ,      &
         & 4.5d1 , 1.0d2/
      data v(1) , v(2) , v(3) , v(4) , v(5) , v(6) , v(7) , v(8) ,      &
         & v(9) , v(10) , v(11)/4.0d0 , 2.0d0 , 1.0d0 , 5.0d-1 ,        &
         & 2.5d-1 , 1.67d-1 , 1.25d-1 , 1.0d-1 , 8.33d-2 , 7.14d-2 ,    &
         & 6.25d-2/
      dfloat(ivar) = ivar
!
!     JACOBIAN ROUTINE SELECTOR.
!
      select case (Nprob)
      case (2)
!
!     LINEAR FUNCTION - RANK 1.
!
         do j = 1 , n
            do i = 1 , m
               Fjac(i,j) = dfloat(i)*dfloat(j)
            enddo
         enddo
      case (3)
!
!     LINEAR FUNCTION - RANK 1 WITH ZERO COLUMNS AND ROWS.
!
         do j = 1 , n
            do i = 1 , m
               Fjac(i,j) = zero
            enddo
         enddo
         nm1 = n - 1
         mm1 = m - 1
         if ( nm1>=2 ) then
            do j = 2 , nm1
               do i = 2 , mm1
                  Fjac(i,j) = dfloat(i-1)*dfloat(j)
               enddo
            enddo
         endif
      case (4)
!
!     ROSENBROCK FUNCTION.
!
         Fjac(1,1) = -c20*x(1)
         Fjac(1,2) = ten
         Fjac(2,1) = -one
         Fjac(2,2) = zero
      case (5)
!
!     HELICAL VALLEY FUNCTION.
!
         tpi = eight*atan(one)
         temp = x(1)**2 + x(2)**2
         tmp1 = tpi*temp
         tmp2 = sqrt(temp)
         Fjac(1,1) = c100*x(2)/tmp1
         Fjac(1,2) = -c100*x(1)/tmp1
         Fjac(1,3) = ten
         Fjac(2,1) = ten*x(1)/tmp2
         Fjac(2,2) = ten*x(2)/tmp2
         Fjac(2,3) = zero
         Fjac(3,1) = zero
         Fjac(3,2) = zero
         Fjac(3,3) = one
      case (6)
!
!     POWELL SINGULAR FUNCTION.
!
         do j = 1 , 4
            do i = 1 , 4
               Fjac(i,j) = zero
            enddo
         enddo
         Fjac(1,1) = one
         Fjac(1,2) = ten
         Fjac(2,3) = sqrt(five)
         Fjac(2,4) = -Fjac(2,3)
         Fjac(3,2) = two*(x(2)-two*x(3))
         Fjac(3,3) = -two*Fjac(3,2)
         Fjac(4,1) = two*sqrt(ten)*(x(1)-x(4))
         Fjac(4,4) = -Fjac(4,1)
      case (7)
!
!     FREUDENSTEIN AND ROTH FUNCTION.
!
         Fjac(1,1) = one
         Fjac(1,2) = x(2)*(ten-three*x(2)) - two
         Fjac(2,1) = one
         Fjac(2,2) = x(2)*(two+three*x(2)) - c14
      case (8)
!
!     BARD FUNCTION.
!
         do i = 1 , 15
            tmp1 = dfloat(i)
            tmp2 = dfloat(16-i)
            tmp3 = tmp1
            if ( i>8 ) tmp3 = tmp2
            tmp4 = (x(2)*tmp2+x(3)*tmp3)**2
            Fjac(i,1) = -one
            Fjac(i,2) = tmp1*tmp2/tmp4
            Fjac(i,3) = tmp1*tmp3/tmp4
         enddo
      case (9)
!
!     KOWALIK AND OSBORNE FUNCTION.
!
         do i = 1 , 11
            tmp1 = v(i)*(v(i)+x(2))
            tmp2 = v(i)*(v(i)+x(3)) + x(4)
            Fjac(i,1) = -tmp1/tmp2
            Fjac(i,2) = -v(i)*x(1)/tmp2
            Fjac(i,3) = Fjac(i,1)*Fjac(i,2)
            Fjac(i,4) = Fjac(i,3)/v(i)
         enddo
      case (10)
!
!     MEYER FUNCTION.
!
         do i = 1 , 16
            temp = five*dfloat(i) + c45 + x(3)
            tmp1 = x(2)/temp
            tmp2 = exp(tmp1)
            Fjac(i,1) = tmp2
            Fjac(i,2) = x(1)*tmp2/temp
            Fjac(i,3) = -tmp1*Fjac(i,2)
         enddo
      case (11)
!
!     WATSON FUNCTION.
!
         do i = 1 , 29
            div = dfloat(i)/c29
            s2 = zero
            dx = one
            do j = 1 , n
               s2 = s2 + dx*x(j)
               dx = div*dx
            enddo
            temp = two*div*s2
            dx = one/div
            do j = 1 , n
               Fjac(i,j) = dx*(dfloat(j-1)-temp)
               dx = div*dx
            enddo
         enddo
         do j = 1 , n
            do i = 30 , 31
               Fjac(i,j) = zero
            enddo
         enddo
         Fjac(30,1) = one
         Fjac(31,1) = -two*x(1)
         Fjac(31,2) = one
      case (12)
!
!     BOX 3-DIMENSIONAL FUNCTION.
!
         do i = 1 , m
            temp = dfloat(i)
            tmp1 = temp/ten
            Fjac(i,1) = -tmp1*exp(-tmp1*x(1))
            Fjac(i,2) = tmp1*exp(-tmp1*x(2))
            Fjac(i,3) = exp(-temp) - exp(-tmp1)
         enddo
      case (13)
!
!     JENNRICH AND SAMPSON FUNCTION.
!
         do i = 1 , m
            temp = dfloat(i)
            Fjac(i,1) = -temp*exp(temp*x(1))
            Fjac(i,2) = -temp*exp(temp*x(2))
         enddo
      case (14)
!
!     BROWN AND DENNIS FUNCTION.
!
         do i = 1 , m
            temp = dfloat(i)/five
            ti = sin(temp)
            tmp1 = x(1) + temp*x(2) - exp(temp)
            tmp2 = x(3) + ti*x(4) - cos(temp)
            Fjac(i,1) = two*tmp1
            Fjac(i,2) = temp*Fjac(i,1)
            Fjac(i,3) = two*tmp2
            Fjac(i,4) = ti*Fjac(i,3)
         enddo
      case (15)
!
!     CHEBYQUAD FUNCTION.
!
         dx = one/dfloat(n)
         do j = 1 , n
            tmp1 = one
            tmp2 = two*x(j) - one
            temp = two*tmp2
            tmp3 = zero
            tmp4 = two
            do i = 1 , m
               Fjac(i,j) = dx*tmp4
               ti = four*tmp2 + temp*tmp4 - tmp3
               tmp3 = tmp4
               tmp4 = ti
               ti = temp*tmp2 - tmp1
               tmp1 = tmp2
               tmp2 = ti
            enddo
         enddo
      case (16)
!
!     BROWN ALMOST-LINEAR FUNCTION.
!
         prod = one
         do j = 1 , n
            prod = x(j)*prod
            do i = 1 , n
               Fjac(i,j) = one
            enddo
            Fjac(j,j) = two
         enddo
         do j = 1 , n
            temp = x(j)
            if ( temp==zero ) then
               temp = one
               prod = one
               do k = 1 , n
                  if ( k/=j ) prod = x(k)*prod
               enddo
            endif
            Fjac(n,j) = prod/temp
         enddo
      case (17)
!
!     OSBORNE 1 FUNCTION.
!
         do i = 1 , 33
            temp = ten*dfloat(i-1)
            tmp1 = exp(-x(4)*temp)
            tmp2 = exp(-x(5)*temp)
            Fjac(i,1) = -one
            Fjac(i,2) = -tmp1
            Fjac(i,3) = -tmp2
            Fjac(i,4) = temp*x(2)*tmp1
            Fjac(i,5) = temp*x(3)*tmp2
         enddo
      case (18)
!
!     OSBORNE 2 FUNCTION.
!
         do i = 1 , 65
            temp = dfloat(i-1)/ten
            tmp1 = exp(-x(5)*temp)
            tmp2 = exp(-x(6)*(temp-x(9))**2)
            tmp3 = exp(-x(7)*(temp-x(10))**2)
            tmp4 = exp(-x(8)*(temp-x(11))**2)
            Fjac(i,1) = -tmp1
            Fjac(i,2) = -tmp2
            Fjac(i,3) = -tmp3
            Fjac(i,4) = -tmp4
            Fjac(i,5) = temp*x(1)*tmp1
            Fjac(i,6) = x(2)*(temp-x(9))**2*tmp2
            Fjac(i,7) = x(3)*(temp-x(10))**2*tmp3
            Fjac(i,8) = x(4)*(temp-x(11))**2*tmp4
            Fjac(i,9) = -two*x(2)*x(6)*(temp-x(9))*tmp2
            Fjac(i,10) = -two*x(3)*x(7)*(temp-x(10))*tmp3
            Fjac(i,11) = -two*x(4)*x(8)*(temp-x(11))*tmp4
         enddo
      case default
!
!     LINEAR FUNCTION - FULL RANK.
!
         temp = two/dfloat(m)
         do j = 1 , n
            do i = 1 , m
               Fjac(i,j) = -temp
            enddo
            Fjac(j,j) = Fjac(j,j) + one
         enddo
      end select
!
!     LAST CARD OF SUBROUTINE SSQJAC.
!
      end

      subroutine initpt(n,x,Nprob,Factor)
      implicit none

      integer n , Nprob
      double precision Factor
      double precision x(n)
!     **********
!
!     SUBROUTINE INITPT
!
!     THIS SUBROUTINE SPECIFIES THE STANDARD STARTING POINTS FOR THE
!     FUNCTIONS DEFINED BY SUBROUTINE SSQFCN. THE SUBROUTINE RETURNS
!     IN X A MULTIPLE (FACTOR) OF THE STANDARD STARTING POINT. FOR
!     THE 11TH FUNCTION THE STANDARD STARTING POINT IS ZERO, SO IN
!     THIS CASE, IF FACTOR IS NOT UNITY, THEN THE SUBROUTINE RETURNS
!     THE VECTOR  X(J) = FACTOR, J=1,...,N.
!
!     THE SUBROUTINE STATEMENT IS
!
!       SUBROUTINE INITPT(N,X,NPROB,FACTOR)
!
!     WHERE
!
!       N IS A POSITIVE INTEGER INPUT VARIABLE.
!
!       X IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE STANDARD
!         STARTING POINT FOR PROBLEM NPROB MULTIPLIED BY FACTOR.
!
!       NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE
!         NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 18.
!
!       FACTOR IS AN INPUT VARIABLE WHICH SPECIFIES THE MULTIPLE OF
!         THE STANDARD STARTING POINT. IF FACTOR IS UNITY, NO
!         MULTIPLICATION IS PERFORMED.
!
!     ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
!     BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
!
!     **********
      integer ivar , j
      double precision c1 , c2 , c3 , c4 , c5 , c6 , c7 , c8 , c9 ,     &
                     & c10 , c11 , c12 , c13 , c14 , c15 , c16 , c17 ,  &
                     & five , h , half , one , seven , ten , three ,    &
                     & twenty , twntf , two , zero
      double precision dfloat
      data zero , half , one , two , three , five , seven , ten ,       &
         & twenty , twntf/0.0d0 , 5.0d-1 , 1.0d0 , 2.0d0 , 3.0d0 ,      &
         & 5.0d0 , 7.0d0 , 1.0d1 , 2.0d1 , 2.5d1/
      data c1 , c2 , c3 , c4 , c5 , c6 , c7 , c8 , c9 , c10 , c11 ,     &
         & c12 , c13 , c14 , c15 , c16 , c17/1.2d0 , 2.5d-1 , 3.9d-1 ,  &
         & 4.15d-1 , 2.0d-2 , 4.0d3 , 2.5d2 , 3.0d-1 , 4.0d-1 , 1.5d0 , &
         & 1.0d-2 , 1.3d0 , 6.5d-1 , 7.0d-1 , 6.0d-1 , 4.5d0 , 5.5d0/
      dfloat(ivar) = ivar
!
!     SELECTION OF INITIAL POINT.
!
      select case (Nprob)
      case (4)
!
!     ROSENBROCK FUNCTION.
!
         x(1) = -c1
         x(2) = one
      case (5)
!
!     HELICAL VALLEY FUNCTION.
!
         x(1) = -one
         x(2) = zero
         x(3) = zero
      case (6)
!
!     POWELL SINGULAR FUNCTION.
!
         x(1) = three
         x(2) = -one
         x(3) = zero
         x(4) = one
      case (7)
!
!     FREUDENSTEIN AND ROTH FUNCTION.
!
         x(1) = half
         x(2) = -two
      case (8)
!
!     BARD FUNCTION.
!
         x(1) = one
         x(2) = one
         x(3) = one
      case (9)
!
!     KOWALIK AND OSBORNE FUNCTION.
!
         x(1) = c2
         x(2) = c3
         x(3) = c4
         x(4) = c3
      case (10)
!
!     MEYER FUNCTION.
!
         x(1) = c5
         x(2) = c6
         x(3) = c7
      case (11)
!
!     WATSON FUNCTION.
!
         do j = 1 , n
            x(j) = zero
         enddo
      case (12)
!
!     BOX 3-DIMENSIONAL FUNCTION.
!
         x(1) = zero
         x(2) = ten
         x(3) = twenty
      case (13)
!
!     JENNRICH AND SAMPSON FUNCTION.
!
         x(1) = c8
         x(2) = c9
      case (14)
!
!     BROWN AND DENNIS FUNCTION.
!
         x(1) = twntf
         x(2) = five
         x(3) = -five
         x(4) = -one
      case (15)
!
!     CHEBYQUAD FUNCTION.
!
         h = one/dfloat(n+1)
         do j = 1 , n
            x(j) = dfloat(j)*h
         enddo
      case (16)
!
!     BROWN ALMOST-LINEAR FUNCTION.
!
         do j = 1 , n
            x(j) = half
         enddo
      case (17)
!
!     OSBORNE 1 FUNCTION.
!
         x(1) = half
         x(2) = c10
         x(3) = -one
         x(4) = c11
         x(5) = c5
      case (18)
!
!     OSBORNE 2 FUNCTION.
!
         x(1) = c12
         x(2) = c13
         x(3) = c13
         x(4) = c14
         x(5) = c15
         x(6) = three
         x(7) = five
         x(8) = seven
         x(9) = two
         x(10) = c16
         x(11) = c17
      case default
!
!     LINEAR FUNCTION - FULL RANK OR RANK 1.
!
         do j = 1 , n
            x(j) = one
         enddo
      end select
!
!     COMPUTE MULTIPLE OF INITIAL POINT.
!
      if ( Factor/=one ) then
         if ( Nprob==11 ) then
            do j = 1 , n
               x(j) = Factor
            enddo
         else
            do j = 1 , n
               x(j) = Factor*x(j)
            enddo
         endif
      endif
!
!     LAST CARD OF SUBROUTINE INITPT.
!
      end

      subroutine ssqfcn(m,n,x,Fvec,Nprob)
      implicit none

      integer m , n , Nprob
      double precision x(n) , Fvec(m)
!     **********
!
!     SUBROUTINE SSQFCN
!
!     THIS SUBROUTINE DEFINES THE FUNCTIONS OF EIGHTEEN NONLINEAR
!     LEAST SQUARES PROBLEMS. THE ALLOWABLE VALUES OF (M,N) FOR
!     FUNCTIONS 1,2 AND 3 ARE VARIABLE BUT WITH M .GE. N.
!     FOR FUNCTIONS 4,5,6,7,8,9 AND 10 THE VALUES OF (M,N) ARE
!     (2,2),(3,3),(4,4),(2,2),(15,3),(11,4) AND (16,3), RESPECTIVELY.
!     FUNCTION 11 (WATSON) HAS M = 31 WITH N USUALLY 6 OR 9.
!     HOWEVER, ANY N, N = 2,...,31, IS PERMITTED.
!     FUNCTIONS 12,13 AND 14 HAVE N = 3,2 AND 4, RESPECTIVELY, BUT
!     ALLOW ANY M .GE. N, WITH THE USUAL CHOICES BEING 10,10 AND 20.
!     FUNCTION 15 (CHEBYQUAD) ALLOWS M AND N VARIABLE WITH M .GE. N.
!     FUNCTION 16 (BROWN) ALLOWS N VARIABLE WITH M = N.
!     FOR FUNCTIONS 17 AND 18, THE VALUES OF (M,N) ARE
!     (33,5) AND (65,11), RESPECTIVELY.
!
!     THE SUBROUTINE STATEMENT IS
!
!       SUBROUTINE SSQFCN(M,N,X,FVEC,NPROB)
!
!     WHERE
!
!       M AND N ARE POSITIVE INTEGER INPUT VARIABLES. N MUST NOT
!         EXCEED M.
!
!       X IS AN INPUT ARRAY OF LENGTH N.
!
!       FVEC IS AN OUTPUT ARRAY OF LENGTH M WHICH CONTAINS THE NPROB
!         FUNCTION EVALUATED AT X.
!
!       NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE
!         NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 18.
!
!     SUBPROGRAMS CALLED
!
!       FORTRAN-SUPPLIED ... atan,cos,exp,sin,sqrt,sign
!
!     ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
!     BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
!
!     **********
      integer i , iev , ivar , j , nm1
      double precision c13 , c14 , c29 , c45 , div , dx , eight , five ,&
                     & one , prod , sum , s1 , s2 , temp , ten , ti ,   &
                     & tmp1 , tmp2 , tmp3 , tmp4 , tpi , two , zero ,   &
                     & zp25 , zp5
      double precision v(11) , y1(15) , y2(11) , y3(16) , y4(33) ,      &
                     & y5(65)
      double precision dfloat
      data zero , zp25 , zp5 , one , two , five , eight , ten , c13 ,   &
         & c14 , c29 , c45/0.0d0 , 2.5d-1 , 5.0d-1 , 1.0d0 , 2.0d0 ,    &
         & 5.0d0 , 8.0d0 , 1.0d1 , 1.3d1 , 1.4d1 , 2.9d1 , 4.5d1/
      data v(1) , v(2) , v(3) , v(4) , v(5) , v(6) , v(7) , v(8) ,      &
         & v(9) , v(10) , v(11)/4.0d0 , 2.0d0 , 1.0d0 , 5.0d-1 ,        &
         & 2.5d-1 , 1.67d-1 , 1.25d-1 , 1.0d-1 , 8.33d-2 , 7.14d-2 ,    &
         & 6.25d-2/
      data y1(1) , y1(2) , y1(3) , y1(4) , y1(5) , y1(6) , y1(7) ,      &
         & y1(8) , y1(9) , y1(10) , y1(11) , y1(12) , y1(13) , y1(14) , &
         & y1(15)/1.4d-1 , 1.8d-1 , 2.2d-1 , 2.5d-1 , 2.9d-1 , 3.2d-1 , &
         & 3.5d-1 , 3.9d-1 , 3.7d-1 , 5.8d-1 , 7.3d-1 , 9.6d-1 ,        &
         & 1.34d0 , 2.1d0 , 4.39d0/
      data y2(1) , y2(2) , y2(3) , y2(4) , y2(5) , y2(6) , y2(7) ,      &
         & y2(8) , y2(9) , y2(10) , y2(11)/1.957d-1 , 1.947d-1 ,        &
         & 1.735d-1 , 1.6d-1 , 8.44d-2 , 6.27d-2 , 4.56d-2 , 3.42d-2 ,  &
         & 3.23d-2 , 2.35d-2 , 2.46d-2/
      data y3(1) , y3(2) , y3(3) , y3(4) , y3(5) , y3(6) , y3(7) ,      &
         & y3(8) , y3(9) , y3(10) , y3(11) , y3(12) , y3(13) , y3(14) , &
         & y3(15) , y3(16)/3.478d4 , 2.861d4 , 2.365d4 , 1.963d4 ,      &
         & 1.637d4 , 1.372d4 , 1.154d4 , 9.744d3 , 8.261d3 , 7.03d3 ,   &
         & 6.005d3 , 5.147d3 , 4.427d3 , 3.82d3 , 3.307d3 , 2.872d3/
      data y4(1) , y4(2) , y4(3) , y4(4) , y4(5) , y4(6) , y4(7) ,      &
         & y4(8) , y4(9) , y4(10) , y4(11) , y4(12) , y4(13) , y4(14) , &
         & y4(15) , y4(16) , y4(17) , y4(18) , y4(19) , y4(20) , y4(21) &
         & , y4(22) , y4(23) , y4(24) , y4(25) , y4(26) , y4(27) ,      &
         & y4(28) , y4(29) , y4(30) , y4(31) , y4(32) , y4(33)/8.44d-1 ,&
         & 9.08d-1 , 9.32d-1 , 9.36d-1 , 9.25d-1 , 9.08d-1 , 8.81d-1 ,  &
         & 8.5d-1 , 8.18d-1 , 7.84d-1 , 7.51d-1 , 7.18d-1 , 6.85d-1 ,   &
         & 6.58d-1 , 6.28d-1 , 6.03d-1 , 5.8d-1 , 5.58d-1 , 5.38d-1 ,   &
         & 5.22d-1 , 5.06d-1 , 4.9d-1 , 4.78d-1 , 4.67d-1 , 4.57d-1 ,   &
         & 4.48d-1 , 4.38d-1 , 4.31d-1 , 4.24d-1 , 4.2d-1 , 4.14d-1 ,   &
         & 4.11d-1 , 4.06d-1/
      data y5(1) , y5(2) , y5(3) , y5(4) , y5(5) , y5(6) , y5(7) ,      &
         & y5(8) , y5(9) , y5(10) , y5(11) , y5(12) , y5(13) , y5(14) , &
         & y5(15) , y5(16) , y5(17) , y5(18) , y5(19) , y5(20) , y5(21) &
         & , y5(22) , y5(23) , y5(24) , y5(25) , y5(26) , y5(27) ,      &
         & y5(28) , y5(29) , y5(30) , y5(31) , y5(32) , y5(33) , y5(34) &
         & , y5(35) , y5(36) , y5(37) , y5(38) , y5(39) , y5(40) ,      &
         & y5(41) , y5(42) , y5(43) , y5(44) , y5(45) , y5(46) , y5(47) &
         & , y5(48) , y5(49) , y5(50) , y5(51) , y5(52) , y5(53) ,      &
         & y5(54) , y5(55) , y5(56) , y5(57) , y5(58) , y5(59) , y5(60) &
         & , y5(61) , y5(62) , y5(63) , y5(64) , y5(65)/1.366d0 ,       &
         & 1.191d0 , 1.112d0 , 1.013d0 , 9.91d-1 , 8.85d-1 , 8.31d-1 ,  &
         & 8.47d-1 , 7.86d-1 , 7.25d-1 , 7.46d-1 , 6.79d-1 , 6.08d-1 ,  &
         & 6.55d-1 , 6.16d-1 , 6.06d-1 , 6.02d-1 , 6.26d-1 , 6.51d-1 ,  &
         & 7.24d-1 , 6.49d-1 , 6.49d-1 , 6.94d-1 , 6.44d-1 , 6.24d-1 ,  &
         & 6.61d-1 , 6.12d-1 , 5.58d-1 , 5.33d-1 , 4.95d-1 , 5.0d-1 ,   &
         & 4.23d-1 , 3.95d-1 , 3.75d-1 , 3.72d-1 , 3.91d-1 , 3.96d-1 ,  &
         & 4.05d-1 , 4.28d-1 , 4.29d-1 , 5.23d-1 , 5.62d-1 , 6.07d-1 ,  &
         & 6.53d-1 , 6.72d-1 , 7.08d-1 , 6.33d-1 , 6.68d-1 , 6.45d-1 ,  &
         & 6.32d-1 , 5.91d-1 , 5.59d-1 , 5.97d-1 , 6.25d-1 , 7.39d-1 ,  &
         & 7.1d-1 , 7.29d-1 , 7.2d-1 , 6.36d-1 , 5.81d-1 , 4.28d-1 ,    &
         & 2.92d-1 , 1.62d-1 , 9.8d-2 , 5.4d-2/
      dfloat(ivar) = ivar
!
!     FUNCTION ROUTINE SELECTOR.
!
      select case (Nprob)
      case (2)
!
!     LINEAR FUNCTION - RANK 1.
!
         sum = zero
         do j = 1 , n
            sum = sum + dfloat(j)*x(j)
         enddo
         do i = 1 , m
            Fvec(i) = dfloat(i)*sum - one
         enddo
      case (3)
!
!     LINEAR FUNCTION - RANK 1 WITH ZERO COLUMNS AND ROWS.
!
         sum = zero
         nm1 = n - 1
         if ( nm1>=2 ) then
            do j = 2 , nm1
               sum = sum + dfloat(j)*x(j)
            enddo
         endif
         do i = 1 , m
            Fvec(i) = dfloat(i-1)*sum - one
         enddo
         Fvec(m) = -one
      case (4)
!
!     ROSENBROCK FUNCTION.
!
         Fvec(1) = ten*(x(2)-x(1)**2)
         Fvec(2) = one - x(1)
      case (5)
!
!     HELICAL VALLEY FUNCTION.
!
         tpi = eight*atan(one)
         tmp1 = sign(zp25,x(2))
         if ( x(1)>zero ) tmp1 = atan(x(2)/x(1))/tpi
         if ( x(1)<zero ) tmp1 = atan(x(2)/x(1))/tpi + zp5
         tmp2 = sqrt(x(1)**2+x(2)**2)
         Fvec(1) = ten*(x(3)-ten*tmp1)
         Fvec(2) = ten*(tmp2-one)
         Fvec(3) = x(3)
      case (6)
!
!     POWELL SINGULAR FUNCTION.
!
         Fvec(1) = x(1) + ten*x(2)
         Fvec(2) = sqrt(five)*(x(3)-x(4))
         Fvec(3) = (x(2)-two*x(3))**2
         Fvec(4) = sqrt(ten)*(x(1)-x(4))**2
      case (7)
!
!     FREUDENSTEIN AND ROTH FUNCTION.
!
         Fvec(1) = -c13 + x(1) + ((five-x(2))*x(2)-two)*x(2)
         Fvec(2) = -c29 + x(1) + ((one+x(2))*x(2)-c14)*x(2)
      case (8)
!
!     BARD FUNCTION.
!
         do i = 1 , 15
            tmp1 = dfloat(i)
            tmp2 = dfloat(16-i)
            tmp3 = tmp1
            if ( i>8 ) tmp3 = tmp2
            Fvec(i) = y1(i) - (x(1)+tmp1/(x(2)*tmp2+x(3)*tmp3))
         enddo
      case (9)
!
!     KOWALIK AND OSBORNE FUNCTION.
!
         do i = 1 , 11
            tmp1 = v(i)*(v(i)+x(2))
            tmp2 = v(i)*(v(i)+x(3)) + x(4)
            Fvec(i) = y2(i) - x(1)*tmp1/tmp2
         enddo
      case (10)
!
!     MEYER FUNCTION.
!
         do i = 1 , 16
            temp = five*dfloat(i) + c45 + x(3)
            tmp1 = x(2)/temp
            tmp2 = exp(tmp1)
            Fvec(i) = x(1)*tmp2 - y3(i)
         enddo
      case (11)
!
!     WATSON FUNCTION.
!
         do i = 1 , 29
            div = dfloat(i)/c29
            s1 = zero
            dx = one
            do j = 2 , n
               s1 = s1 + dfloat(j-1)*dx*x(j)
               dx = div*dx
            enddo
            s2 = zero
            dx = one
            do j = 1 , n
               s2 = s2 + dx*x(j)
               dx = div*dx
            enddo
            Fvec(i) = s1 - s2**2 - one
         enddo
         Fvec(30) = x(1)
         Fvec(31) = x(2) - x(1)**2 - one
      case (12)
!
!     BOX 3-DIMENSIONAL FUNCTION.
!
         do i = 1 , m
            temp = dfloat(i)
            tmp1 = temp/ten
            Fvec(i) = exp(-tmp1*x(1)) - exp(-tmp1*x(2))               &
                    & + (exp(-temp)-exp(-tmp1))*x(3)
         enddo
      case (13)
!
!     JENNRICH AND SAMPSON FUNCTION.
!
         do i = 1 , m
            temp = dfloat(i)
            Fvec(i) = two + two*temp - exp(temp*x(1)) - exp(temp*x(2))
         enddo
      case (14)
!
!     BROWN AND DENNIS FUNCTION.
!
         do i = 1 , m
            temp = dfloat(i)/five
            tmp1 = x(1) + temp*x(2) - exp(temp)
            tmp2 = x(3) + sin(temp)*x(4) - cos(temp)
            Fvec(i) = tmp1**2 + tmp2**2
         enddo
      case (15)
!
!     CHEBYQUAD FUNCTION.
!
         do i = 1 , m
            Fvec(i) = zero
         enddo
         do j = 1 , n
            tmp1 = one
            tmp2 = two*x(j) - one
            temp = two*tmp2
            do i = 1 , m
               Fvec(i) = Fvec(i) + tmp2
               ti = temp*tmp2 - tmp1
               tmp1 = tmp2
               tmp2 = ti
            enddo
         enddo
         dx = one/dfloat(n)
         iev = -1
         do i = 1 , m
            Fvec(i) = dx*Fvec(i)
            if ( iev>0 ) Fvec(i) = Fvec(i) + one/(dfloat(i)**2-one)
            iev = -iev
         enddo
      case (16)
!
!     BROWN ALMOST-LINEAR FUNCTION.
!
         sum = -dfloat(n+1)
         prod = one
         do j = 1 , n
            sum = sum + x(j)
            prod = x(j)*prod
         enddo
         do i = 1 , n
            Fvec(i) = x(i) + sum
         enddo
         Fvec(n) = prod - one
      case (17)
!
!     OSBORNE 1 FUNCTION.
!
         do i = 1 , 33
            temp = ten*dfloat(i-1)
            tmp1 = exp(-x(4)*temp)
            tmp2 = exp(-x(5)*temp)
            Fvec(i) = y4(i) - (x(1)+x(2)*tmp1+x(3)*tmp2)
         enddo
      case (18)
!
!     OSBORNE 2 FUNCTION.
!
         do i = 1 , 65
            temp = dfloat(i-1)/ten
            tmp1 = exp(-x(5)*temp)
            tmp2 = exp(-x(6)*(temp-x(9))**2)
            tmp3 = exp(-x(7)*(temp-x(10))**2)
            tmp4 = exp(-x(8)*(temp-x(11))**2)
            Fvec(i) = y5(i) - (x(1)*tmp1+x(2)*tmp2+x(3)*tmp3+x(4)*tmp4)
         enddo
      case default
!
!     LINEAR FUNCTION - FULL RANK.
!
         sum = zero
         do j = 1 , n
            sum = sum + x(j)
         enddo
         temp = two*sum/dfloat(m) + one
         do i = 1 , m
            Fvec(i) = -temp
            if ( i<=n ) Fvec(i) = Fvec(i) + x(i)
         enddo
      end select
!
!     LAST CARD OF SUBROUTINE SSQFCN.
!
      end


      SUBROUTINE STIMTD( LINE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL,
     $                   NLDA, LDAVAL, TIMMIN, A, B, D, TAU, WORK,
     $                   RESLTS, LDR1, LDR2, LDR3, NOUT )
*
*  -- LAPACK timing routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     March 31, 1993
*
*     .. Scalar Arguments ..
      CHARACTER*80       LINE
      INTEGER            LDR1, LDR2, LDR3, NLDA, NM, NN, NNB, NOUT
      REAL               TIMMIN
*     ..
*     .. Array Arguments ..
      INTEGER            LDAVAL( * ), MVAL( * ), NBVAL( * ), NVAL( * ),
     $                   NXVAL( * )
      REAL               A( * ), B( * ), D( * ),
     $                   RESLTS( LDR1, LDR2, LDR3, * ), TAU( * ),
     $                   WORK( * )
*     ..
*
*  Purpose
*  =======
*
*  STIMTD times the LAPACK routines SSYTRD, SORGTR, and SORMTR and the
*  EISPACK routine TRED1.
*
*  Arguments
*  =========
*
*  LINE    (input) CHARACTER*80
*          The input line that requested this routine.  The first six
*          characters contain either the name of a subroutine or a
*          generic path name.  The remaining characters may be used to
*          specify the individual routines to be timed.  See ATIMIN for
*          a full description of the format of the input line.
*
*  NM      (input) INTEGER
*          The number of values of M contained in the vector MVAL.
*
*  MVAL    (input) INTEGER array, dimension (NM)
*          The values of the matrix size M.
*
*  NN      (input) INTEGER
*          The number of values of N contained in the vector NVAL.
*
*  NVAL    (input) INTEGER array, dimension (NN)
*          The values of the matrix column dimension N.
*
*  NNB     (input) INTEGER
*          The number of values of NB and NX contained in the
*          vectors NBVAL and NXVAL.  The blocking parameters are used
*          in pairs (NB,NX).
*
*  NBVAL   (input) INTEGER array, dimension (NNB)
*          The values of the blocksize NB.
*
*  NXVAL   (input) INTEGER array, dimension (NNB)
*          The values of the crossover point NX.
*
*  NLDA    (input) INTEGER
*          The number of values of LDA contained in the vector LDAVAL.
*
*  LDAVAL  (input) INTEGER array, dimension (NLDA)
*          The values of the leading dimension of the array A.
*
*  TIMMIN  (input) REAL
*          The minimum time a subroutine will be timed.
*
*  A       (workspace) REAL array, dimension (LDAMAX*NMAX)
*          where LDAMAX and NMAX are the maximum values of LDA and N.
*
*  B       (workspace) REAL array, dimension (LDAMAX*NMAX)
*
*  D       (workspace) REAL array, dimension (2*NMAX-1)
*
*  TAU     (workspace) REAL array, dimension (NMAX)
*
*  WORK    (workspace) REAL array, dimension (NMAX*NBMAX)
*          where NBMAX is the maximum value of NB.
*
*  RESLTS  (workspace) REAL array, dimension
*                      (LDR1,LDR2,LDR3,4*NN+3)
*          The timing results for each subroutine over the relevant
*          values of M, (NB,NX), LDA, and N.
*
*  LDR1    (input) INTEGER
*          The first dimension of RESLTS.  LDR1 >= max(1,NNB).
*
*  LDR2    (input) INTEGER
*          The second dimension of RESLTS.  LDR2 >= max(1,NM).
*
*  LDR3    (input) INTEGER
*          The third dimension of RESLTS.  LDR3 >= max(1,2*NLDA).
*
*  NOUT    (input) INTEGER
*          The unit number for output.
*
*  Internal Parameters
*  ===================
*
*  MODE    INTEGER
*          The matrix type.  MODE = 3 is a geometric distribution of
*          eigenvalues.  See SLATMS for further details.
*
*  COND    REAL
*          The condition number of the matrix.  The singular values are
*          set to values from DMAX to DMAX/COND.
*
*  DMAX    REAL
*          The magnitude of the largest singular value.
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            NSUBS
      PARAMETER          ( NSUBS = 4 )
      INTEGER            MODE
      REAL               COND, DMAX
      PARAMETER          ( MODE = 3, COND = 100.0E0, DMAX = 1.0E0 )
*     ..
*     .. Local Scalars ..
      CHARACTER          LAB1, LAB2, SIDE, TRANS, UPLO
      CHARACTER*3        PATH
      CHARACTER*6        CNAME
      INTEGER            I, I3, I4, IC, ICL, ILDA, IM, IN, INB, INFO,
     $                   ISIDE, ISUB, ITOFF, ITRAN, IUPLO, LDA, LW, M,
     $                   M1, N, N1, NB, NX
      REAL               OPS, S1, S2, TIME, UNTIME
*     ..
*     .. Local Arrays ..
      LOGICAL            TIMSUB( NSUBS )
      CHARACTER          SIDES( 2 ), TRANSS( 2 ), UPLOS( 2 )
      CHARACTER*6        SUBNAM( NSUBS )
      INTEGER            ISEED( 4 ), RESEED( 4 )
*     ..
*     .. External Functions ..
      REAL               SECOND, SMFLOP, SOPLA
      EXTERNAL           SECOND, SMFLOP, SOPLA
*     ..
*     .. External Subroutines ..
      EXTERNAL           ATIMCK, ATIMIN, ICOPY, SLACPY, SLATMS, SORGTR,
     $                   SORMTR, SPRTB3, SPRTBL, SSYTRD, STIMMG, TRED1,
     $                   XLAENV
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, REAL
*     ..
*     .. Data statements ..
      DATA               SUBNAM / 'SSYTRD', 'TRED1', 'SORGTR',
     $                   'SORMTR' /
      DATA               SIDES / 'L', 'R' / , TRANSS / 'N', 'T' / ,
     $                   UPLOS / 'U', 'L' /
      DATA               ISEED / 0, 0, 0, 1 /
*     ..
*     .. Executable Statements ..
*
*     Extract the timing request from the input line.
*
      PATH( 1: 1 ) = 'Single precision'
      PATH( 2: 3 ) = 'TD'
      CALL ATIMIN( PATH, LINE, NSUBS, SUBNAM, TIMSUB, NOUT, INFO )
      IF( INFO.NE.0 )
     $   GO TO 240
*
*     Check that M <= LDA for the input values.
*
      CNAME = LINE( 1: 6 )
      CALL ATIMCK( 2, CNAME, NM, MVAL, NLDA, LDAVAL, NOUT, INFO )
      IF( INFO.GT.0 ) THEN
         WRITE( NOUT, FMT = 9999 )CNAME
         GO TO 240
      END IF
*
*     Check that K <= LDA for SORMTR
*
      IF( TIMSUB( 4 ) ) THEN
         CALL ATIMCK( 3, CNAME, NN, NVAL, NLDA, LDAVAL, NOUT, INFO )
         IF( INFO.GT.0 ) THEN
            WRITE( NOUT, FMT = 9999 )SUBNAM( 4 )
            TIMSUB( 4 ) = .FALSE.
         END IF
      END IF
*
*     Do first for UPLO = 'U', then for UPLO = 'L'
*
      DO 150 IUPLO = 1, 2
         UPLO = UPLOS( IUPLO )
*
*        Do for each value of M:
*
         DO 140 IM = 1, NM
            M = MVAL( IM )
            CALL ICOPY( 4, ISEED, 1, RESEED, 1 )
*
*           Do for each value of LDA:
*
            DO 130 ILDA = 1, NLDA
               LDA = LDAVAL( ILDA )
               I3 = ( IUPLO-1 )*NLDA + ILDA
*
*              Do for each pair of values (NB, NX) in NBVAL and NXVAL.
*
               DO 120 INB = 1, NNB
                  NB = NBVAL( INB )
                  CALL XLAENV( 1, NB )
                  NX = NXVAL( INB )
                  CALL XLAENV( 3, NX )
                  LW = MAX( 1, M*MAX( 1, NB ) )
*
*                 Generate a test matrix of order M.
*
                  CALL ICOPY( 4, RESEED, 1, ISEED, 1 )
                  CALL SLATMS( M, M, 'Uniform', ISEED, 'Symmetric', TAU,
     $                         MODE, COND, DMAX, M, M, 'No packing', B,
     $                         LDA, WORK, INFO )
*
                  IF( TIMSUB( 2 ) .AND. INB.EQ.1 .AND. IUPLO.EQ.2 ) THEN
*
*                    TRED1:  Eispack reduction using orthogonal
*                    transformations.
*
                     CALL SLACPY( UPLO, M, M, B, LDA, A, LDA )
                     IC = 0
                     S1 = SECOND( )
   10                CONTINUE
                     CALL TRED1( LDA, M, A, D, D( M+1 ), D( M+1 ) )
                     S2 = SECOND( )
                     TIME = S2 - S1
                     IC = IC + 1
                     IF( TIME.LT.TIMMIN ) THEN
                        CALL SLACPY( UPLO, M, M, B, LDA, A, LDA )
                        GO TO 10
                     END IF
*
*                    Subtract the time used in SLACPY.
*
                     ICL = 1
                     S1 = SECOND( )
   20                CONTINUE
                     S2 = SECOND( )
                     UNTIME = S2 - S1
                     ICL = ICL + 1
                     IF( ICL.LE.IC ) THEN
                        CALL SLACPY( UPLO, M, M, B, LDA, A, LDA )
                        GO TO 20
                     END IF
*
                     TIME = ( TIME-UNTIME ) / REAL( IC )
                     OPS = SOPLA( 'SSYTRD', M, M, -1, -1, NB )
                     RESLTS( INB, IM, ILDA, 2 ) = SMFLOP( OPS, TIME,
     $                  INFO )
                  END IF
*
                  IF( TIMSUB( 1 ) ) THEN
*
*                    SSYTRD:  Reduction to tridiagonal form
*
                     CALL SLACPY( UPLO, M, M, B, LDA, A, LDA )
                     IC = 0
                     S1 = SECOND( )
   30                CONTINUE
                     CALL SSYTRD( UPLO, M, A, LDA, D, D( M+1 ), TAU,
     $                            WORK, LW, INFO )
                     S2 = SECOND( )
                     TIME = S2 - S1
                     IC = IC + 1
                     IF( TIME.LT.TIMMIN ) THEN
                        CALL SLACPY( UPLO, M, M, B, LDA, A, LDA )
                        GO TO 30
                     END IF
*
*                    Subtract the time used in SLACPY.
*
                     ICL = 1
                     S1 = SECOND( )
   40                CONTINUE
                     S2 = SECOND( )
                     UNTIME = S2 - S1
                     ICL = ICL + 1
                     IF( ICL.LE.IC ) THEN
                        CALL SLACPY( UPLO, M, M, A, LDA, B, LDA )
                        GO TO 40
                     END IF
*
                     TIME = ( TIME-UNTIME ) / REAL( IC )
                     OPS = SOPLA( 'SSYTRD', M, M, -1, -1, NB )
                     RESLTS( INB, IM, I3, 1 ) = SMFLOP( OPS, TIME,
     $                  INFO )
                  ELSE
*
*                    If SSYTRD was not timed, generate a matrix and
*                    factor it using SSYTRD anyway so that the factored
*                    form of the matrix can be used in timing the other
*                    routines.
*
                     CALL SLACPY( UPLO, M, M, B, LDA, A, LDA )
                     CALL SSYTRD( UPLO, M, A, LDA, D, D( M+1 ), TAU,
     $                            WORK, LW, INFO )
                  END IF
*
                  IF( TIMSUB( 3 ) ) THEN
*
*                    SORGTR:  Generate the orthogonal matrix Q from the
*                    reduction to Hessenberg form A = Q*H*Q'
*
                     CALL SLACPY( UPLO, M, M, A, LDA, B, LDA )
                     IC = 0
                     S1 = SECOND( )
   50                CONTINUE
                     CALL SORGTR( UPLO, M, B, LDA, TAU, WORK, LW, INFO )
                     S2 = SECOND( )
                     TIME = S2 - S1
                     IC = IC + 1
                     IF( TIME.LT.TIMMIN ) THEN
                        CALL SLACPY( UPLO, M, M, A, LDA, B, LDA )
                        GO TO 50
                     END IF
*
*                    Subtract the time used in SLACPY.
*
                     ICL = 1
                     S1 = SECOND( )
   60                CONTINUE
                     S2 = SECOND( )
                     UNTIME = S2 - S1
                     ICL = ICL + 1
                     IF( ICL.LE.IC ) THEN
                        CALL SLACPY( UPLO, M, M, A, LDA, B, LDA )
                        GO TO 60
                     END IF
*
                     TIME = ( TIME-UNTIME ) / REAL( IC )
*
*                    Op count for SORGTR:  same as
*                       SORGQR( N-1, N-1, N-1, ... )
*
                     OPS = SOPLA( 'SORGQR', M-1, M-1, M-1, -1, NB )
                     RESLTS( INB, IM, I3, 3 ) = SMFLOP( OPS, TIME,
     $                  INFO )
                  END IF
*
                  IF( TIMSUB( 4 ) ) THEN
*
*                    SORMTR:  Multiply by Q stored as a product of
*                    elementary transformations
*
                     I4 = 3
                     DO 110 ISIDE = 1, 2
                        SIDE = SIDES( ISIDE )
                        DO 100 IN = 1, NN
                           N = NVAL( IN )
                           LW = MAX( 1, MAX( 1, NB )*N )
                           IF( ISIDE.EQ.1 ) THEN
                              M1 = M
                              N1 = N
                           ELSE
                              M1 = N
                              N1 = M
                           END IF
                           ITOFF = 0
                           DO 90 ITRAN = 1, 2
                              TRANS = TRANSS( ITRAN )
                              CALL STIMMG( 0, M1, N1, B, LDA, 0, 0 )
                              IC = 0
                              S1 = SECOND( )
   70                         CONTINUE
                              CALL SORMTR( SIDE, UPLO, TRANS, M1, N1, A,
     $                                     LDA, TAU, B, LDA, WORK, LW,
     $                                     INFO )
                              S2 = SECOND( )
                              TIME = S2 - S1
                              IC = IC + 1
                              IF( TIME.LT.TIMMIN ) THEN
                                 CALL STIMMG( 0, M1, N1, B, LDA, 0, 0 )
                                 GO TO 70
                              END IF
*
*                             Subtract the time used in STIMMG.
*
                              ICL = 1
                              S1 = SECOND( )
   80                         CONTINUE
                              S2 = SECOND( )
                              UNTIME = S2 - S1
                              ICL = ICL + 1
                              IF( ICL.LE.IC ) THEN
                                 CALL STIMMG( 0, M1, N1, B, LDA, 0, 0 )
                                 GO TO 80
                              END IF
*
                              TIME = ( TIME-UNTIME ) / REAL( IC )
*
*                             Op count for SORMTR, SIDE='L':  same as
*                                SORMQR( 'L', TRANS, M-1, N, M-1, ...)
*
*                             Op count for SORMTR, SIDE='R':  same as
*                                SORMQR( 'R', TRANS, M, N-1, N-1, ...)
*
                              IF( ISIDE.EQ.1 ) THEN
                                 OPS = SOPLA( 'SORMQR', M1-1, N1, M1-1,
     $                                 -1, NB )
                              ELSE
                                 OPS = SOPLA( 'SORMQR', M1, N1-1, N1-1,
     $                                 1, NB )
                              END IF
*
                              RESLTS( INB, IM, I3,
     $                           I4+ITOFF+IN ) = SMFLOP( OPS, TIME,
     $                           INFO )
                              ITOFF = NN
   90                      CONTINUE
  100                   CONTINUE
                        I4 = I4 + 2*NN
  110                CONTINUE
                  END IF
*
  120          CONTINUE
  130       CONTINUE
  140    CONTINUE
  150 CONTINUE
*
*     Print tables of results for SSYTRD, TRED1, and SORGTR
*
      DO 180 ISUB = 1, NSUBS - 1
         IF( .NOT.TIMSUB( ISUB ) )
     $      GO TO 180
         WRITE( NOUT, FMT = 9998 )SUBNAM( ISUB )
         IF( NLDA.GT.1 ) THEN
            DO 160 I = 1, NLDA
               WRITE( NOUT, FMT = 9997 )I, LDAVAL( I )
  160       CONTINUE
         END IF
         IF( ISUB.EQ.2 ) THEN
            WRITE( NOUT, FMT = * )
            CALL SPRTB3( ' ', 'N', 1, NBVAL, NXVAL, NM, MVAL, NLDA,
     $                   RESLTS( 1, 1, 1, ISUB ), LDR1, LDR2, NOUT )
         ELSE
            I3 = 1
            DO 170 IUPLO = 1, 2
               WRITE( NOUT, FMT = 9996 )SUBNAM( ISUB ), UPLOS( IUPLO )
               CALL SPRTB3( '(  NB,  NX)', 'N', NNB, NBVAL, NXVAL, NM,
     $                      MVAL, NLDA, RESLTS( 1, 1, I3, ISUB ), LDR1,
     $                      LDR2, NOUT )
               I3 = I3 + NLDA
  170       CONTINUE
         END IF
  180 CONTINUE
*
*     Print tables of results for SORMTR
*
      ISUB = 4
      IF( TIMSUB( ISUB ) ) THEN
         I4 = 3
         DO 230 ISIDE = 1, 2
            IF( ISIDE.EQ.1 ) THEN
               LAB1 = 'M'
               LAB2 = 'N'
               IF( NLDA.GT.1 ) THEN
                  WRITE( NOUT, FMT = 9998 )SUBNAM( ISUB )
                  DO 190 I = 1, NLDA
                     WRITE( NOUT, FMT = 9997 )I, LDAVAL( I )
  190             CONTINUE
               END IF
            ELSE
               LAB1 = 'N'
               LAB2 = 'M'
            END IF
            DO 220 ITRAN = 1, 2
               DO 210 IN = 1, NN
                  I3 = 1
                  DO 200 IUPLO = 1, 2
                     WRITE( NOUT, FMT = 9995 )SUBNAM( ISUB ),
     $                  SIDES( ISIDE ), UPLOS( IUPLO ), TRANSS( ITRAN ),
     $                  LAB2, NVAL( IN )
                     CALL SPRTBL( 'NB', LAB1, NNB, NBVAL, NM, MVAL,
     $                            NLDA, RESLTS( 1, 1, I3, I4+IN ), LDR1,
     $                            LDR2, NOUT )
                     I3 = I3 + NLDA
  200             CONTINUE
  210          CONTINUE
               I4 = I4 + NN
  220       CONTINUE
  230    CONTINUE
      END IF
  240 CONTINUE
*
*     Print a table of results for each timed routine.
*
 9999 FORMAT( 1X, A6, ' timing run not attempted', / )
 9998 FORMAT( / ' *** Speed of ', A6, ' in megaflops *** ' )
 9997 FORMAT( 5X, 'line ', I2, ' with LDA = ', I5 )
 9996 FORMAT( / 5X, A6, ' with UPLO = ''', A1, '''', / )
 9995 FORMAT( / 5X, A6, ' with SIDE = ''', A1, ''', UPLO = ''', A1,
     $      ''', TRANS = ''', A1, ''', ', A1, ' =', I6, / )
      RETURN
*
*     End of STIMTD
*
      END


SUBROUTINE symop(theta,fi)
  !     for .orhto. systems   opimat == imat
  !     for not.ortho. systems opimat == BR1 . imat . BR1^-1
  USE rotmat
  USE struct
  IMPLICIT REAL*8 (A-H,O-Z)
  REAL*8 BR1in(3,3),opimat(3,3),rot(3,3),rotinv(3,3),trans(3,3), tmp(3,3)
  REAL*8 rloc(3,3),sloc(3,3),th(10),ph(10)
  LOGICAL          ORTHO
  COMMON /ORTH/   ORTHO
  COMMON /GENER/  BR1(3,3),BR2(3,3)
  !.........inverssymdef is a subroutine in sph-UP.frc and
  !.........calculates the inverse of an 3*3 matrix.......
  pi=acos(-1.d0)
  CALL INVERSSYMDEF(BR1,BR1in)
  ct=dcos(theta)
  cf=dcos(fi)
  st=dsin(theta)
  sf=dsin(fi)
!!! rot is the spin coordinate system, in which case.inso (h,k,l) points in z direction
!!! more precisely, it takes the following form
!!!  ( e_{theta}, e_{phi}, e_r ),
!!! where e_{theta}, e_{phi} and e_r are unit vectors in spherical coordinate system.
  rot(1,1)=cf*ct
  rot(1,2)=-sf
  rot(1,3)=cf*st
  rot(2,1)=sf*ct
  rot(2,2)=cf
  rot(2,3)=sf*st
  rot(3,1)=-st
  rot(3,2)=0
  rot(3,3)=ct
  call INVERSSYMDEF(rot,rotinv)
  ! sloc  = Det* rotloc * (BR1 * rotij * BR1^{-1}) * rot
  !   my understanding:
  !   sloc :  local_to_first <- from_first_to_each <- global <- spin-coordinate-system
  !
  ! trans =    rot^{-1} * (BR1 * rotij * BR1^{-1}) * rot
  !   my understanding:
  !   trans : spin-coordinate-system <- global <- spin-coordinate-system
  indj=0
  do jatom=1,nat
     do mu=1,mult(jatom)
	indj=indj+1
!!!     rotij specified the transformation between the first atom of certain type
!!!         and all other atoms of the same type
!!!     opimat is like rotij in cartesian coordinates, i.e.,
!!!         opimat = BR1 * rotij * BR1^{-1}
        tmp(:,:) = matmul(BR1(:,:),rotij(:,:,indj))
        opimat(:,:) = matmul(tmp,BR1in(:,:))
!!!     trans is now rotij transofrmed to spin coordinate system,
!!!         namely, in the axis in which spin is quantizied
        call transform(trans,rotinv,opimat,rot)
!!!     rloc transforms into local coordinate system attached to indj atom.
!!!         To achieve this, we first transformed (using rotij) from the coordinate
!!!         system attached to the first atom, to the other atom, and then into
!!!         local coordinate system (using rotloc).
        rloc(:,:) = matmul(rotloc(:,:,jatom),opimat(:,:))
!!!     Here we will perform proper rotation only (inversion does not change spin).
!!!     sloc is spin coordinate system written in local coordinate system.
        tt=determinant(rloc)
        sloc = matmul(rloc,rot) * tt

        !        write(6,*)'ATOM:',indj
        ! write(6,*)'local coord. system:'
        ! do ii=1,3
        ! write(6,5)(rloc(ii,jj),jj=1,3)
        ! end do
        ! write(6,*)'rotij:'
        ! do ii=1,3
        ! write(6,5)(rotij(ii,jj,indj),jj=1,3)
        ! end do
        ! write(6,*)'opimat:'
        ! do ii=1,3
        ! write(6,5)(opimat(ii,jj),jj=1,3)
        ! end do
        ! write(6,*)
        ! write(6,*)'spin with respect to local coord.:'
        ! do ii=1,3
        ! write(6,5)(sloc(ii,jj),jj=1,3)
        ! end do
        ! write(6,*)

        call euler(sloc,a,b,c)
        !! Now we calculate <Y_{lms}|l*s|Y_{l'm's'}> matrix elements
        !! but we rotate the spin into the local coordinate system of each atom,
        !! in which L is specified.
        call couple(indj,a,b,c)

        det(indj)=trans(1,1)*trans(2,2)-trans(1,2)*trans(2,1)
        if (abs(1.-abs(det(indj))).gt.1.d-2) then
           write(6,*)'WRONG SYMMETRY in spin pol. case'
           write(6,555)indj,det(indj)
        endif

	DD=determinant(trans)
        if (DD.lt.-0.5) then
           trans(:,:) = -trans(:,:)
        end if

        call euler(trans,a,b,c)
        !       write(6,3)indj,a*180/pi,b*180/pi,c*180/pi
        if (det(indj).gt.0.5) then
           phase(indj)=a+c
        else
           phase(indj)=a-c
        end if
        !       write(6,4)det(indj),phase(indj)
     enddo
  enddo
3 format(i2,1x,'Euler angles: a,b,c:  ',3f7.1)
4 format('det=',f3.0,' phase=',f8.4)
5 format(3f12.7)
555 format(' atom',i3,' det',f10.5)
end SUBROUTINE symop

subroutine transform(T,Pinv,A,P)
  IMPLICIT REAL*8 (A-H,O-Z)
  DIMENSION T(3,3),P(3,3),A(3,3),Pinv(3,3), tmp(3,3)
  tmp = matmul(Pinv,A)
  T = matmul(tmp,P)
  !do i=1,3
  !   do j=1,3
  !      sum=0
  !      do k=1,3
  !         do l=1,3
  !            sum=sum+Pinv(i,k)*A(k,l)*P(l,j)
  !         end do
  !      end do
  !      T(i,j)=sum
  !   end do
  !end do
  return
end subroutine transform

SUBROUTINE INVERSSYMDEF(A,AINV)
  IMPLICIT REAL*8 (A-H,O-Z)
  DIMENSION A(3,3),AINV(3,3)
  det= determinant(a)
  AINV(1,1) =(   A(2,2) * A(3,3) - A(2,3) * A(3,2) ) / det
  AINV(2,1) =( - A(2,1) * A(3,3) + A(2,3) * A(3,1) ) / det
  AINV(3,1) =(   A(2,1) * A(3,2) - A(2,2) * A(3,1) ) / det
  AINV(1,2) =( - A(1,2) * A(3,3) + A(1,3) * A(3,2) ) / det
  AINV(2,2) =(   A(1,1) * A(3,3) - A(1,3) * A(3,1) ) / det
  AINV(3,2) =( - A(1,1) * A(3,2) + A(1,2) * A(3,1) ) / det
  AINV(1,3) =(   A(1,2) * A(2,3) - A(1,3) * A(2,2) ) / det
  AINV(2,3) =( - A(1,1) * A(2,3) + A(1,3) * A(2,1) ) / det
  AINV(3,3) =(   A(1,1) * A(2,2) - A(1,2) * A(2,1) ) / det
  RETURN
END SUBROUTINE INVERSSYMDEF

REAL*8 FUNCTION determinant(A)
  REAL* 8 A(3,3)
  determinant=a(1,1)*a(2,2)*a(3,3)+a(1,2)*a(2,3)*a(3,1)+a(1,3)*a(2,1)*a(3,2)-a(3,1)*a(2,2)*a(1,3)-a(1,1)*a(3,2)*a(2,3)-a(2,1)*a(1,2)*a(3,3)
END FUNCTION determinant