      subroutine qmdiag(tm11,tm12,tm13,tm14,
     1     tm21,tm22,tm23,tm24,
     1     tm31,tm32,tm33,tm34,
     1     tm41,tm42,tm43,tm44,
     1     r1,r2,r3,r4,c,stab,nanq,lfno)
c
c---- This subroutine find a transformation matrix---
c     which diagonalizes 4*4 transfer matrix.
c     M = S-1.Md.S
c     where
c     Md = (A, 0)
c     (0, B)
c
c     tm** ; transfer matrix( input )
c     r*   ; transformation matrix( output )
c     S = (c, J.(r)t.J)
c     (r,    c    )
c---------------------------------------------------
      use tfstk, only: ktfenanq
      implicit none
      real*8 , intent(in)::tm11,tm12,tm13,tm14,
     1     tm21,tm22,tm23,tm24,
     1     tm31,tm32,tm33,tm34,
     1     tm41,tm42,tm43,tm44
      real*8 , intent(out)::r1,r2,r3,r4,c
      real*8 trpq,trab2,c2,aa,
     $     detn,trqk,trqj,aaa,bbb,ccc,p1,p2,p3,p4,trp,trqkj2,
     $     trql,xx11,xx12,xx21,xx22,yy11,yy12,yy21,yy22
      integer*4 , intent(inout)::lfno
      logical*4, intent(out):: stab,nanq
      stab=.true.
      nanq=.false.
c
      trpq = tm11 + tm22 - tm33 - tm44
c.....trpq =(TrP-TrQ)
      trab2 = 4.d0*(
     $     (tm31+tm24)*(tm42+tm13)+(tm14-tm32)*(tm41-tm23))
     1     +trpq**2
c      trab2 = 8.d0*(tm31*tm42-tm32*tm41)
c     1     +4.d0*(tm31*tm13+tm32*tm23
c     1     +tm41*tm14+tm42*tm24)
c     1     +trpq*trpq
c.....trab2=(TrA-TrB)**2 should be positive or zero.
c     ::::::::::::::::
C--   deb
c      print *,'===qmdiag=== trab2 =',trab2
      if(ktfenanq(trab2))then
        write(lfno,'(a,1p5g15.7)')
     $       '***qmdiag---> Matrix not a number: ',trab2,
     $       tm11,tm22,tm33,tm44
        lfno=0
        stab=.false.
        nanq=.true.
        return
      endif
      if( trab2.ge.1.d-14 ) then
c     +++++++++++++++++++++
c==   > +  (TrA-TrB)^2 > 0  +
c     +++++++++++++++++++++
c
c-----Normal case
c     :::::::::::
C--   deb
c     print *,'---> trab2>0'
        c2 = 0.5d0*(1.d0 + abs(trpq)/sqrt(trab2))
        c  = sqrt(c2)
        if( trpq.ge.0.d0 ) then
          aa = -1.d0/c/sqrt(trab2)
        else
          aa =  1.d0/c/sqrt(trab2)
        end if
        r1 = aa*(tm31 + tm24)
        r2 = aa*(tm32 - tm14)
        r3 = aa*(tm41 - tm23)
        r4 = aa*(tm42 + tm13)
      else if( abs(trab2).le.1.d-14 ) then
c     +++++++++++++++++++++
c==   > +  (TrA-TrB)^2 = 0  +
c     +++++++++++++++++++++
c     This necessarily leads TrP = TrQ.
c
C--   deb
c     print *,'---> trpq=0 ,trab2=0'
        detn = tm13*tm24-tm14*tm23
        if( abs(detn).ge.1.d-14 ) then
c     -----------------
c-------> +  det(N) =/ 0  +
c     -----------------
          trqk = tm33 - tm44
          if( abs(trqk).ge.1.d-7 ) then
c-----------Case of Tr(QK) =/ 0
            trqj = tm43 - tm34
            trqkj2 = (trqk+trqj)*(trqk-trqj)
            if( abs(trqkj2).ge.1.d-14 ) then
c...........Case of (TrQK)**2 =/ (TrQJ)**2
              c   = 1.d0
              bbb = -detn/(trqj+trqk)
              ccc = 0.d0
            else
c...........Case of (TrQK)**2 = (TrQJ)**2
              if( abs(trqj).ge.1.d-7 ) then
c     [ Tr(QJ) =/ 0 ]
c     ..This condition must be always satisfied
c     because Tr(QK)=/0 and Tr(QK)**2=Tr(QJ)**2.
                c   = 1.d0
                bbb = -0.5d0*detn/trqj
                ccc = 0.d0
              else
                print *,'+++QMDIAG Logics is broken. Check tm**'
                print *,tm11,tm12,tm13,tm14
                print *,tm21,tm22,tm23,tm24
                print *,tm31,tm32,tm33,tm34
                print *,tm41,tm42,tm43,tm44
                print *,'trqk,trqj,trqkj2=',trqk,trqk,trqkj2
c     begin initialize for preventing compiler warning
                bbb = 0.d0
c     end   initialize for preventing compiler warning
              end if
            end if
            aaa  = ( detn*(1.d0-2.d0*c*c)/c - bbb*trqj )/trqk
          else
c-----------Case of Tr(QK) = 0
            trqj = tm43 - tm34
            if( abs(trqj).ge.1.d-7 ) then
c...........Case of TrQJ =/ 0
              c   = 1.d0
              aaa = detn/trqj
              bbb =-detn/trqj
              ccc = 0.d0
            else
c...........Case of TrQJ = 0
              trql = tm34 + tm43
              if( abs(trql).ge.1.d-7 ) then
c     [ Tr(QL) =/ 0 ]
                c   = 1.d0
                aaa = 0.d0
                bbb = detn/trql
                ccc =-detn/trql
              else
c     [ Tr(QL) =  0 ]
                c   = 1.d0/sqrt(2.d0)
                if( detn.gt.0.d0 ) then
c     ( Det(N) > 0 )
                  aaa = 0.d0
                  bbb = sqrt(detn/2.d0)
                  ccc = 0.d0
                else
c     ( Det(N) < 0 )
                  aaa = sqrt(-detn/2.d0)
                  bbb = 0.d0
                  ccc = 0.d0
                end if
              end if
            end if
          end if
          xx11 =  aaa
          xx12 =  bbb + ccc
          xx21 = -bbb + ccc
          xx22 = -aaa
          r1   = ( xx11*tm24-xx12*tm23)/detn
          r2   = (-xx11*tm14+xx12*tm13)/detn
          r3   = ( xx21*tm24-xx22*tm23)/detn
          r4   = (-xx21*tm14+xx22*tm13)/detn
        else
c     -----------------
c-------> +  det(N) =  0  +
c     -----------------
c     print *,'---detn=0,detn=',detn
          trqk = tm33 - tm44
          trqj = tm43 - tm34
          trql = tm43 + tm34
          if( abs(trqk).ge.1.d-7 ) then
c-----------Case of Tr(QK) =/ 0
            aaa = 0.d0
            bbb = 0.d0
            ccc = 1.d0/trqk
          else if( abs(trqj).ge.1.d-7 ) then
c-----------Case of Tr(QJ) =/ 0
            aaa = -1.d0/trqj
            bbb = 0.d0
            ccc = 0.d0
          else if( abs(trql).ge.1.d-7 ) then
c-----------Case of Tr(QL) =/ 0
            aaa = 0.d0
            bbb = -1.d0/trql
            ccc = 0.d0
          else
            go to 1000
          end if
          c    = 1.d0
          yy11 = aaa + bbb
          yy12 = ccc
          yy21 = ccc
          yy22 = aaa - bbb
          r1   = yy11*(-tm23) + yy12*(-tm24)
          r2   = yy11*tm13    + yy12*tm14
          r3   = yy21*(-tm23) + yy22*(-tm24)
          r4   = yy21*tm13    + yy22*tm14
          go to 2000
 1000     continue
c-----------Case of Tr(QJ) = Tr(QL) = Tr(QK) = 0
          trp = tm11 + tm22
          p1  = tm11 - 0.5d0*trp
          p2  = tm12
          p3  = tm21
          p4  = tm22 - 0.5d0*trp
          if( abs(p3).ge.1.d-7 ) then
c...........Case of (P-1/2*TrP*I)3 =/ 0
            c  = 1.d0
            r1 = 0.d0
            r2 = tm24/p3
            r3 = 0.d0
            r4 = -tm23/p3
          else if( abs(p1).ge.1.d-7 ) then
c...........Case of (P-1/2*TrP*I)3 = 0 and (P-1/2*TrP*I)1 =/ 0
            c  = 1.d0
            r1 = tm24/p1
            r2 = 0.d0
            r3 = -tm23/p1
            r4 = 0.d0
          else
c...........Case of (P-1/2*TrP*I)3 = 0 and (P-1/2*TrP*I)1 =  0
            c  = 1.d0/sqrt(2.d0)
            r1 = 1.d0
            r2 = 0.d0
            r3 = 0.d0
            r4 = c
          end if
 2000     continue
        end if
      else
c     ?????????????????????
c==   > ?  (TrA-TrB)^2 < 0  ?
c     ?????????????????????
c
c     print *,'+++QMDIAG Strange transfer matrix !!!!!'
c     print *,tm11,tm12,tm13,tm14
c     print *,tm21,tm22,tm23,tm24
c     print *,tm31,tm32,tm33,tm34
c     print *,tm41,tm42,tm43,tm44
        if(lfno .gt. 0)then
          write(lfno,*)
     $   '***qmdiag---> Sum resonance: (TrA-TrB)^2 =',trab2
          lfno=0
        endif
        stab=.false.
      endif
      return
      end


C++********************************************************************
C Program COORD_NORMALIZE to
C normalize lists of coordinates generated with GRINNEL or XYCURA
C Scale=1., centre=(0.,0.), north at 90 degrees.
C (For shell coordinates, to be used before EFIT6)
C
C JLP  Version of 20-01-88
C--********************************************************************
	PROGRAM COORD_NORMALIZE
	PARAMETER (IDIM=1000,IDIM1=2000)
	REAL*4 XTT(IDIM1),YTT(IDIM1),XOUT(IDIM1),YOUT(IDIM1)
	REAL*4 WORKX2(IDIM),WORKY2(IDIM)
	CHARACTER IN_FILE*40,IN_COMMENTS*80,OUTNAME*40,NAME*70,ANS*1
	LOGICAL INVERSE

10	FORMAT(A)

	PRINT 111
111	FORMAT(' Normalization of a set of coordinates',/,
     1	' Scale=1., centre=(0.,0.), north at 90 degrees')

C***************************
C Entering the positions :
C***************************
	PRINT 112
112	FORMAT(' ARE YOU WORKING WITH :',/,
     1	' 1. A SET OF SHELLS FROM "XYCURA1"',/,
     1	' 2. A SET OF SHELLS FROM "GRINNEL"',/,
     1	' 3. A SINGLE SHELL  ?')
	READ(5,*) IOPT

	PRINT *,' ENTER THE POSITION FILE :'
	 IF(IOPT.EQ.1)THEN
C Option 1 for the format :
	   CALL RREADFILE(XTT,YTT,NTT,WORKX2,WORKY2,I,IDIM1,
     1                    IN_FILE,IN_COMMENTS,1)
	 ELSEIF(IOPT.EQ.2)THEN
C Option 6 for the format :
	   CALL RREADFILE(XTT,YTT,NTT,WORKX2,WORKY2,I,IDIM1,
     1                    IN_FILE,IN_COMMENTS,6)
	 ELSE
C Option 0 (=unknown) for the format :
	    CALL RREADFILE(X,Y,NPOINT,WORKX2,WORKY2,I,IDIM1,
     1                     IN_FILE,IN_COMMENTS,0)
	 ENDIF

C Output file compatible with SHELL_PROC
	 PRINT *,' (THE OUTPUT WILL BE WRITTEN WITH THE "GRINNEL" FORMAT)'
302	 PRINT *,' NAME OF THE OUTPUT FILE ?'
	 READ(5,10) OUTNAME
	 OPEN(1,FILE=OUTNAME,STATUS='NEW',ERR=302)

C Entering the parameters for the transformation :

	PRINT *,' CENTRE OF THE GALAXY : X0, Y0 ?'
	READ(5,*) X0,Y0

	PRINT *,' Scale in arcsec/pixel ?'
	READ(5,*) SCALE

	PRINT *,' Position angle of the North in the frame ? (Degrees, x=0.)'
	READ(5,*) ANORTH

	PRINT *,' Is the image orientated as WEST-NORTH-EAST ? (Y)'
	READ(5,10) ANS
	INVERSE=(ANS.EQ.'n'.OR.ANS.EQ.'N')

	CALL CNRZ_TRANSFORM(XTT,YTT,NTT,X0,Y0,SCALE,ANORTH,INVERSE,
     1	XOUT,YOUT)

C Writing a header:
	 PRINT *,' NAME OF THE ORIGINAL FILE (FOR THE TITLE)?'
	 READ(5,10) NAME
	WRITE(1,98) NAME,X0,Y0,ANORTH,SCALE
98	FORMAT(' FILE :',A80,/,
     1	' CENTRE:',2(X,G10.3),' ANORTH: ',G10.3,
     1	' SCALE: ',G10.3)

C Writing the output on the file
	DO I=1,NTT
	  WRITE(1,*)NINT(XOUT(I)),NINT(YOUT(I)),0.0
	END DO

C****** End ********
999	CLOSE(1)
	PRINT *,' '

	STOP
	END
C********************************************************************
C Subroutine CNRZ_TRANSFORM
C normalize lists of coordinates
C Scale=1., centre=(0.,0.), north at 90 degrees.
C
C********************************************************************
	SUBROUTINE CNRZ_TRANSFORM(XTT,YTT,NTT,X0,Y0,SCALE,
     1	ANORTH,INVERSE,XOUT,YOUT)
	PARAMETER (IDIM=1000,IDIM1=2000)
	REAL*4 XTT(IDIM1),YTT(IDIM1),XOUT(IDIM1),YOUT(IDIM1)
	LOGICAL INVERSE

10	FORMAT(A)

C Normalizing the input list :
	DO I=1,NTT
	  IF(XTT(I).NE.-1000..OR.YTT(I).NE.-1000.)THEN
	    XTT(I)=(XTT(I)-X0)*SCALE
	    YTT(I)=(YTT(I)-Y0)*SCALE
	  ENDIF
	END DO

C Rotation of (90.-ANORTH) :
	  COSA=COSD(90.-ANORTH)
	  SINA=SIND(90.-ANORTH)
	  DO I=1,NTT
	    IF(XTT(I).NE.-1000..OR.YTT(I).NE.-1000.)THEN
	      XOUT(I)=COSA*XTT(I)-SINA*YTT(I)
	      YOUT(I)=SINA*XTT(I)+COSA*YTT(I)
	    ELSE
	      XOUT(I)=-1000.
	      YOUT(I)=-1000.
	    ENDIF
	  END DO

C Symmetry relative to the north axis:
	IF(INVERSE)THEN
	  DO I=1,NTT
	    IF(XOUT(I).NE.-1000..OR.YOUT(I).NE.-1000.)THEN
	      XOUT(I)=-1.*XOUT(I)
	    ENDIF
	  END DO
	ENDIF

	RETURN
	END
C**************************************************************************


      module single_particle
        use, intrinsic :: iso_fortran_env, only : REAL64, INT16, INT32, INT64

        ! Some parameters for simulation
        integer head, colls_dt, tidx
        integer Nspace
        parameter(Nspace=100)
        real(REAL64) es(Nspace), tcs(Nspace), e0

      contains

        subroutine onepart()
          use eedf, only : Ntimes
          use physics, only : dt, tfin
          implicit none

          real(REAL64) t

          ! Initialize simulation
          t = 0.0_REAL64
          tidx = 1
          head = 1
          call init_arrays(Nspace, es, e0, tcs)

          ! Collect initial state
          call collect(0, head)

          ! Run simulation of one electron
          do while (tidx .le. Ntimes .and. t .le. tfin)
            ! reset collision counter
            colls_dt = 0
            ! propagate for dt
            call propagate(dt, head)
            ! collect snapshot histogram
            call collect(tidx, head)
            ! update current time and index
            t = t+dt
            tidx = tidx + 1
          enddo

          ! if tfin/dt is not even, propagate to tfin
          if (t .lt. tfin .and. (abs(tfin-t) .gt. dt*1e-6)) then
            call propagate(tfin-t, head)
            ! collect final value
            call collect(tidx-1, head)
          end if
        end subroutine onepart

        subroutine init_arrays(N, es, e0, tcs)
          use physics, only : collision_time

          implicit none

          integer N
          real(REAL64) es(N), tcs(N), e0

          es = 0.0D0
          tcs = 0.0D0

          es(1) = e0
          tcs(1) = collision_time()
        end subroutine init_arrays

        subroutine propagate(dt, head)
          use physics, only : handle_collision

          implicit none

          real(REAL64) dt, dtp
          integer i, head

          do i=1, head
            dtp = dt
            do while(tcs(i) .le. dtp .and. tcs(i) .gt. 0)
              dtp = dtp - tcs(i)
              call handle_collision(Nspace,es,tcs,i,head,colls_dt)
            enddo

            tcs(i) = tcs(i) - dtp
          enddo

          ! update head to include new collisions
          head = head + colls_dt

        end subroutine propagate

        subroutine collect(tidx, head)
          use eedf, only : eedfbins, Needfbins, de
          implicit none

          integer i, idx, tidx, head

          do i=1, head
            idx = int(es(i)/de)
            if (idx .eq. 0) then
              idx = 1
            end if
            eedfbins(idx, tidx) = eedfbins(idx, tidx) + 1
          enddo
        end subroutine collect

      end module single_particle


!> \file mo_pi_index.f90

!> \brief Parameter sensitivity estimation using Parameter importance (PI) index.

!> \details This module contains routines to determine parameter sensitivities using
!>          the Parameter importance index (PI) based on the eigendecomposition of the sensitivity matrix.\n
!>          Based on pi.py which is part of the JAMS Python library.

!> \authors Juliane Mai
!> \date Jul 2013
MODULE mo_pi_index

  ! Written  Juliane Mai, Jul 2013

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

  ! If you use this routine in your work, you should cite the following reference
  ! Goehler M, J Mai, and M Cuntz (2013)
  !     Use of eigendecomposition in a parameter sensitivity analysis of the Community Land Model,
  !     J Geophys Res 188, 904-921, doi:10.1002/jgrg.20072

  USE mo_kind,   ONLY: i4, sp, dp
  USE mo_mad,    ONLY: mad

  IMPLICIT NONE

  PUBLIC :: pi_index         ! Parameter importance index

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

  !     NAME
  !         pi_index

  !     PURPOSE
  !>        \brief The parameter importance index (PI).
  !
  !>        \details Calculates the parameter importance index which is based on the eigendecomposition of \f$ S^T S \f$
  !>                 where S is the sensitivity matrix. The sensitivity matrix S contains nomalized approximates of
  !>                 the first partial derivatives, i.e. the change of the model due to a small change of the parameter.\n
  !>                 Either the sensitivity matrix S or the matrix \f$ M = S^T S \f$ can be given. \n
  !>                 If S is given, an apriori outlier test (MAD: domad) can be applied to the columns of the S matrix and
  !>                 the columnwise number of valid entries of matrix S (counter) can be returned.\n
  !>                 Optionally, the eigenvalues and eigenvectors can be reurned. \n
  !>                 There are different options to normalize the estimated sensitivity index. \n
  !>                 Optionally, the B index (b_index) which is a sensitivity index neglecting covariations between
  !>                 parameters can be returned.
  !>                 The same normalization (norm) will be applied to both the B index and the PI index.
  !>
  !
  !     INTENT(IN)
  !         None
  !
  !     INTENT(INOUT)
  !         None

  !     INTENT(OUT)
  !         \param[out] "real(sp/dp)           :: pi(:)"       Parameter importance index per parameter
  !
  !     INTENT(IN), OPTIONAL
  !>       \param[in] "real(sp/dp), optional   :: s(:,:)"      Sensitivity matrix \n
  !>                                                              dim_1 = number of parameter sets \n
  !>                                                              dim_2 = number of parameters
  !>       \param[in] "real(sp/dp), optional   :: m(:,:)"      \f$ M = S^T S \f$ \n
  !>                                                              dim_1 = dim_2 = number of parameters \n
  !>       \param[in] "integer(i4), optional   :: norm"        Normalization of index \n
  !>                                                              0 - no normalization (default) \n
  !>                                                              1 - normalized such that all PI sum up to 1 \n
  !>                                                              2 - normalized by sum of eigenvalues \n
  !>                                                              3 - normalized by sum of eigenvalues and
  !>                                                                   subsequently by sum of PI indexes
  !>       \param[in] "logical,     optional   :: domad"       If MAD outlier test should be performed on each
  !>                                                              column of matrix S. \n
  !>                                                              Only applicable if s is present. \n
  !>                                                              Default: .false.
  !
  !     INTENT(INOUT), OPTIONAL
  !         None
  !
  !     INTENT(OUT), OPTIONAL
  !>       \param[out] "integer(i4), allocatable, optional :: counter(:)"    Returns number of valid entries in
  !>                                                                            matrix S per column. \n
  !>                                                                            Only applicable if s is present. \n
  !>       \param[out] "real(sp/dp), optional              :: evalues(:)"    Eigenvalues of \f$ M = S^T S \f$ \n
  !>       \param[out] "real(sp/dp), optional              :: evectors(:,:)" Eigenvectors of \f$ M = S^T S \f$ \n
  !>       \param[out] "real(sp/dp), optional              :: b_index(:)"    B index, i.e. diagonal elements of M \n
  !>                                                                         normalized using norm \n

  !
  !     RETURN
  !        None
  !
  !     RESTRICTIONS
  !>       \note Needs Lapack. \n
  !>             Some options are only applicable if matrix S is present. \n
  !
  !     EXAMPLE
  !         s(:,1) = (/ 1.0, 2.0, 3.0, -999., 5.0, 6.0 /)
  !         s(:,2) = (/ 1.2, 2.5, 3.4, -999., 5.2, 6.8 /)
  !         call pi_index(pi, s=s)
  !         -> see also example in test directory

  !     LITERATURE
  !         Vajda, S., Valko, P., & Turanyi, T. (2004).
  !              Principal component analysis of kinetic models.
  !              International Journal of Chemical Kinetics, 17(1), 55-81.
  !         Goehler, M., Mai, J., & Cuntz, M. (2013).
  !              Use of eigendecomposition in a parameter sensitivity analysis of the Community Land Model.
  !              Journal of Geophysical Research: Biogeosciences, 118(2), 904-921. doi:10.1002/jgrg.20072

  !     HISTORY
  !>        \author Juliane Mai
  !>        \date Jul 2013
  !         Modified,

  !     The code is based on pi.py by Matthias Cuntz. pi.py is part of the JAMS Python library.

  INTERFACE pi_index
     MODULE PROCEDURE pi_index_dp, pi_index_sp
  END INTERFACE pi_index

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

  PRIVATE

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

CONTAINS

#ifndef __PYTHON__
  subroutine pi_index_dp(pi_index_out, s, m, norm, domad, counter, evalues, evectors, b_index)
#else
  subroutine pi_index_dp(pi_index_out, s, m, norm, domad)
#endif

    real(dp), dimension(:),                   intent(out)           :: pi_index_out     ! Parameter importance index
    !                                         ! either S or M has to be given
    real(dp), dimension(:,:),                 intent(in),  optional :: s            ! sensitivity matrix S
    real(dp), dimension(:,:),                 intent(in),  optional :: m            ! M = S^T.S
    integer(i4),                              intent(in),  optional :: norm         ! normalization of PI index
    !                                                                               ! 0 - no normalization (DEFAULT)
    !                                                                               ! 1 - normalized such that all PI sum up to 1
    !                                                                               ! 2 - normalized by sum of eigenvalues
    !                                                                               ! 3 - normalized by sum of eigenvalues and
    !                                                                               !     subsequently by sum of PI indexes
    logical,                                  intent(in),  optional :: domad        ! .true. : prior mad oulier test on S matrix
    !                                                                               ! restriction: S matrix must to be given
    !                                                                               ! DEFAULT: .false.
#ifndef __PYTHON__
    integer(i4), dimension(:),   allocatable, intent(out), optional :: counter      ! number of valid entries in column of S matrix
    real(dp),    dimension(:),   allocatable, intent(out), optional :: evalues      ! eigenvalues of M
    real(dp),    dimension(:,:), allocatable, intent(out), optional :: evectors     ! eigenvectors of M
    real(dp),    dimension(:),   allocatable, intent(out), optional :: b_index      ! B index = sensitivity index neglecting
    !                                                                               ! covariations, i.e. diagonal elements of
    !                                                                               ! matrix M normalized using norm
#endif

    ! local variables
    integer(i4)                              :: ii, jj, ii_count, jj_count
    integer(i4)                              :: ipar
    integer(i4)                              :: npar        ! number of parameters
    logical                                  :: my_mad      ! if mad-test should performed or not
    integer(i4)                              :: my_norm
    logical,     dimension(:,:), allocatable :: mask
    logical,     dimension(:),   allocatable :: maskpara
    real(dp),    dimension(:,:), allocatable :: my_s
    real(dp),    dimension(:,:), allocatable :: my_m
    integer(i4), dimension(:,:), allocatable :: imask
    integer(i4), dimension(:,:), allocatable :: ntrue
    integer(i4), dimension(:),   allocatable :: my_counter  ! number of valid entries in ith column of matrix S
    real(dp),    dimension(:),   allocatable :: my_evalues  ! eigenvalues of M
    real(dp),    dimension(:,:), allocatable :: my_evectors ! eigenvectors of M
    integer(i4)                              :: lwork, info
    real(dp),    dimension(:),   allocatable :: work
    logical,     dimension(:),   allocatable :: tmpmad

    external :: dsyev

    if ( (.not. present(s) .and. .not. present(m)) .or.  (present(s) .and. present(m)) ) then
       stop 'pi_index_dp: either s or m has to be given'
    end if

    if (present(domad)) then
       my_mad = domad
    else
       my_mad = .false.
    end if

    npar = size(pi_index_out)
    allocate( maskpara(npar) )
    maskpara = .true.

    if (present(s)) then
       if ( npar .ne. size(s,2) ) stop 'pi_index_dp: size of s is not matching'
       allocate(my_counter(npar))
       my_counter = size(s,1)

       if (my_mad) then
          allocate( my_s(size(s,1),npar) )
          allocate( my_m(npar,npar) )
          allocate( imask(size(s,1),npar) )
          allocate( mask(size(s,1),npar) )
          allocate( ntrue(npar,npar) )
          allocate( tmpmad(size(s,1)) )

          mask     = .true.
          ! mask = .false. if entry in S matrix is zero (i.e. no response of model to change)
          where (abs(s) .lt. tiny(1.0_dp))
             mask = .false.
          end where
          ! maskpara = true,  if there are not only zeros in column of matrix S
          ! maskpara = false, if there are only zeros in column of matrix S
          maskpara = (count(mask,dim=1) .ne. 0_i4)
          do ipar=1, npar
             if (maskpara(ipar)) then
                tmpmad = mad(s(:,ipar), mask=mask(:,ipar), z=15.0_dp)
                mask(:,ipar)   = mask(:,ipar) .and. tmpmad
                my_counter(ipar) = count(mask(:,ipar))
                maskpara(ipar) = ( my_counter(ipar) .ne. 0_i4)
             else
                my_counter(ipar) = 0_i4
             end if
          end do

          imask = 1_i4
          my_s  = s
          ! set outliers in matrix S to zero
          where (.not. mask)
             imask = 0_i4
             my_s  = 0.0_dp
          end where
          ntrue = matmul(transpose(imask),imask)

          ! matrix M
          my_m = matmul(transpose(my_s),my_s)

          ! delete colums and rows in matrix M where maskpara=false
          allocate( my_evalues(count(maskpara)) )
          allocate (my_evectors(count(maskpara),count(maskpara)))
          ii_count = 0_i4
          do ii=1,npar
             if (maskpara(ii)) ii_count = ii_count + 1
             jj_count = 0_i4
             do jj=1,npar
                if (maskpara(jj)) jj_count = jj_count + 1
                if (maskpara(ii) .and. maskpara(jj)) then
                   my_evectors(ii_count, jj_count) = my_m(ii,jj)
                   ! and scale entries
                   my_evectors(ii_count, jj_count) = my_evectors(ii_count, jj_count) * real(size(my_s,1)) / real(ntrue(ii,jj),dp)
                end if
             end do
          end do

          deallocate(my_s)
          deallocate(my_m)
          deallocate(imask)
          deallocate(mask)
          deallocate(ntrue)
       else
          allocate( my_evalues(count(maskpara)) )
          allocate( my_evectors(count(maskpara),count(maskpara)) )
          my_evectors = matmul(transpose(s),s)
       end if
    else
       if ( (npar .ne. size(m,1)) .or. (npar .ne. size(m,2)) ) stop 'pi_index_dp: size of m is not matching'
#ifndef __PYTHON__
       if ( present(counter) ) stop 'pi_index_dp: argument counter only applicable if matrix S is given'
#endif
       allocate( my_evalues(count(maskpara)) )
       allocate( my_evectors(count(maskpara),count(maskpara)) )
       my_evectors = m
    end if

    if (present(norm)) then
       my_norm = norm
    else
       my_norm =  0
    end if

#ifndef __PYTHON__
    if (present(b_index)) then
       allocate(b_index(npar))
       forall(ii=1:npar) b_index(ii) = my_evectors(ii,ii)
       ! Normalize B index
       select case(my_norm)
       case(0_i4)  ! No normalization
          b_index = b_index
       case(1_i4)  ! Normalized such that B sum up to one
          b_index = b_index / sum(b_index)
       case(2_i4)  ! Normalized by sum of eigenvalues
          b_index = b_index / sum(my_evalues)
       case(3_i4)  ! Normalized by sum of eigenvalues and subsequent by sum of B
          b_index = b_index / sum(my_evalues)
          b_index = b_index / sum(b_index)
       case default
          stop 'pi_index_dp: This normalization method is not implemented.'
       end select
    end if
#endif

    ! Eigenvalues of Covariance Matrix
    ! (1) Query for optimal workspace: lwork=-1
    allocate(work(1))
    lwork = -1_i4
    call dsyev( 'V', 'L', count(maskpara), my_evectors, count(maskpara), my_evalues, work, lwork, info )
    lwork =int( work(1) )
    deallocate(work)

    ! (2) allocate "work" with proper length
    allocate(work(lwork))

    ! (3) calculate eigenvalues
    call dsyev( 'V', 'L', count(maskpara), my_evectors, count(maskpara), my_evalues, work, lwork, info )

    ! (4) Info statement
    if ( info .gt. 0_i4 ) then
       stop 'pi_index_dp: The algorithm failed to compute eigenvalues.'
    end if
    deallocate(work)

    ! Make Eigenvalues all non-negative
    my_evalues(:) = Max(0.0_dp, my_evalues(:))

    ! Calculate PI index
    ii_count = 0_i4
    do ipar=1, npar
       if (maskpara(ipar)) then
          ii_count = ii_count + 1
          pi_index_out(ipar) = dot_product(abs(my_evectors(ii_count,:)), my_evalues)
       else
          pi_index_out(ipar) = 0.0_dp
       end if
    end do

    ! Normalize PI index
    select case(my_norm)
    case(0_i4)  ! No normalization
       pi_index_out = pi_index_out
    case(1_i4)  ! Normalized such that PI sum up to one
       pi_index_out = pi_index_out / sum(pi_index_out)
    case(2_i4)  ! Normalized by sum of eigenvalues
       pi_index_out = pi_index_out / sum(my_evalues)
    case(3_i4)  ! Normalized by sum of eigenvalues and subsequent by sum of PI
       pi_index_out = pi_index_out / sum(my_evalues)
       pi_index_out = pi_index_out / sum(pi_index_out)
    case default
       stop 'pi_index_dp: This normalization method is not implemented.'
    end select

#ifndef __PYTHON__
    if (present(counter)) then
       allocate(counter(npar))
       counter = my_counter
    end if

    if (present(evalues)) then
       allocate(evalues(npar))
       evalues = my_evalues
    end if

    if (present(evectors)) then
       allocate(evectors(npar,npar))
       evectors = my_evectors
    end if
#endif

    deallocate(my_counter)
    deallocate(my_evalues)
    deallocate(my_evectors)

  end subroutine pi_index_dp

#ifndef __PYTHON__
  subroutine pi_index_sp(pi_index_out, s, m, norm, domad, counter, evalues, evectors)
#else
  subroutine pi_index_sp(pi_index_out, s, m, norm, domad)
#endif

    real(sp), dimension(:),                   intent(out)           :: pi_index_out     ! Parameter importance index
    ! either S or M has to be given
    real(sp), dimension(:,:),                 intent(in),  optional :: s            ! sensitivity matrix S
    real(sp), dimension(:,:),                 intent(in),  optional :: m            ! M = S^T.S
    integer(i4),                              intent(in),  optional :: norm         ! normalized PI index
    !                                                                               ! 0 - no normalization (DEFAULT)
    !                                                                               ! 1 - normalized such that all PI sum up to 1
    !                                                                               ! 2 - normalized by sum of eigenvalues
    !                                                                               ! 3 - noramlized by sum of eigenvalues and
    !                                                                               !     subsequently by sum of PI indexes
    logical,                                  intent(in),  optional :: domad        ! .true. : prior mad oulier test on S matrix
    !                                                                               ! restriction: S matrix must to be given
    !                                                                               ! DEFAULT: .false.
#ifndef __PYTHON__
    integer(i4), dimension(:),   allocatable, intent(out), optional :: counter      ! number of valid entries in column of S matrix
    real(sp),    dimension(:),   allocatable, intent(out), optional :: evalues      ! eigenvalues of M
    real(sp),    dimension(:,:), allocatable, intent(out), optional :: evectors     ! eigenvectors of M
#endif

    ! local variables
    integer(i4)                              :: ii, jj, ii_count, jj_count
    integer(i4)                              :: ipar
    integer(i4)                              :: npar        ! number of parameters
    logical                                  :: my_mad      ! if mad-test should performed or not
    integer(i4)                              :: my_norm
    logical,     dimension(:,:), allocatable :: mask
    logical,     dimension(:),   allocatable :: maskpara
    real(sp),    dimension(:,:), allocatable :: my_s
    real(sp),    dimension(:,:), allocatable :: my_m
    integer(i4), dimension(:,:), allocatable :: imask
    integer(i4), dimension(:,:), allocatable :: ntrue
    integer(i4), dimension(:),   allocatable :: my_counter  ! number of valid entries in ith column of matrix S
    real(sp),    dimension(:),   allocatable :: my_evalues  ! eigenvalues of M
    real(sp),    dimension(:,:), allocatable :: my_evectors ! eigenvectors of M
    integer(i4)                              :: lwork, info
    real(sp),    dimension(:),   allocatable :: work
    logical,     dimension(:),   allocatable :: tmpmad

    external :: ssyev

    if ( (.not. present(s) .and. .not. present(m)) .or.  (present(s) .and. present(m)) ) then
       stop 'pi_index_sp: either s or m has to be given'
    end if

    if (present(domad)) then
       my_mad = domad
    else
       my_mad = .false.
    end if

    npar = size(pi_index_out)
    allocate( maskpara(npar) )
    maskpara = .true.

    if (present(s)) then
       if ( npar .ne. size(s,2) ) stop 'pi_index_sp: size of s is not matching'
       allocate(my_counter(npar))
       my_counter = size(s,1)

       if (my_mad) then
          allocate( my_s(size(s,1),npar) )
          allocate( my_m(npar,npar) )
          allocate( imask(size(s,1),npar) )
          allocate( mask(size(s,1),npar) )
          allocate( ntrue(npar,npar) )
          allocate( tmpmad(size(s,1)) )

          mask     = .true.
          ! mask = .false. if entry in S matrix is zero (i.e. no response of model to change)
          where (abs(s) .lt. tiny(1.0_sp))
             mask = .false.
          end where
          ! maskpara = true,  if there are not only zeros in column of matrix S
          ! maskpara = false, if there are only zeros in column of matrix S
          maskpara = (count(mask,dim=1) .ne. 0_i4)
          do ipar=1, npar
             if (maskpara(ipar)) then
                tmpmad = mad(s(:,ipar), mask=mask(:,ipar), z=15.0_sp)
                mask(:,ipar)   = mask(:,ipar) .and. tmpmad
                my_counter(ipar) = count(mask(:,ipar))
                maskpara(ipar) = ( my_counter(ipar) .ne. 0_i4)
             else
                my_counter(ipar) = 0_i4
             end if
          end do

          imask = 1_i4
          my_s  = s
          ! set outliers in matrix S to zero
          where (.not. mask)
             imask = 0_i4
             my_s  = 0.0_sp
          end where
          ntrue = matmul(transpose(imask),imask)

          ! matrix M
          my_m = matmul(transpose(my_s),my_s)

          ! delete colums and rows in matrix M where maskpara=false
          allocate( my_evalues(count(maskpara)) )
          allocate (my_evectors(count(maskpara),count(maskpara)))
          ii_count = 0_i4
          do ii=1,npar
             if (maskpara(ii)) ii_count = ii_count + 1
             jj_count = 0_i4
             do jj=1,npar
                if (maskpara(jj)) jj_count = jj_count + 1
                if (maskpara(ii) .and. maskpara(jj)) then
                   my_evectors(ii_count, jj_count) = my_m(ii,jj)
                   ! and scale entries
                   my_evectors(ii_count, jj_count) = my_evectors(ii_count, jj_count) * real(size(my_s,1)) / real(ntrue(ii,jj),sp)
                end if
             end do
          end do

          deallocate(my_s)
          deallocate(my_m)
          deallocate(imask)
          deallocate(mask)
          deallocate(ntrue)
       else
          allocate( my_evalues(count(maskpara)) )
          allocate( my_evectors(count(maskpara),count(maskpara)) )
          my_evectors = matmul(transpose(s),s)
       end if
    else
       if ( (npar .ne. size(m,1)) .or. (npar .ne. size(m,2)) ) stop 'pi_index_sp: size of m is not matching'
#ifndef __PYTHON__
       if ( present(counter) ) stop 'pi_index_sp: argument counter only applicable if matrix S is given'
#endif
       allocate( my_evalues(count(maskpara)) )
       allocate( my_evectors(count(maskpara),count(maskpara)) )
       my_evectors = m
    end if

    if (present(norm)) then
       my_norm = norm
    else
       my_norm =  0
    end if

    ! Eigenvalues of Covariance Matrix
    ! (1) Query for optimal workspace: lwork=-1
    allocate(work(1))
    lwork = -1_i4
    call ssyev( 'Vectors', 'Lower', count(maskpara), my_evectors, count(maskpara), my_evalues, work, lwork, info )
    lwork =int( work(1) )
    deallocate(work)

    ! (2) allocate "work" with proper length
    allocate(work(lwork))

    ! (3) calculate eigenvalues
    call ssyev( 'Vectors', 'Lower', count(maskpara), my_evectors, count(maskpara), my_evalues, work, lwork, info )

    ! (4) Info statement
    if ( info .gt. 0_i4 ) then
       stop 'pi_index_sp: The algorithm failed to compute eigenvalues.'
    end if
    deallocate(work)

    ! Make Eigenvalues all non-negative
    my_evalues(:) = Max(0.0_sp, my_evalues(:))

    ! Calculate PI index
    ii_count = 0_i4
    do ipar=1, npar
       if (maskpara(ipar)) then
          ii_count = ii_count + 1
          pi_index_out(ipar) = dot_product(abs(my_evectors(ii_count,:)), my_evalues)
       else
          pi_index_out(ipar) = 0.0_sp
       end if
    end do

    ! Normalize PI index
    select case(my_norm)
    case(0_i4)  ! No normalization
       pi_index_out = pi_index_out
    case(1_i4)  ! Normalized such that PI sum up to one
       pi_index_out = pi_index_out / sum(pi_index_out)
    case(2_i4)  ! Normalized by sum of eigenvalues
       pi_index_out = pi_index_out / sum(my_evalues)
    case(3_i4)  ! Normalized by sum of eigenvalues and subsequent by sum of PI
       pi_index_out = pi_index_out / sum(my_evalues)
       pi_index_out = pi_index_out / sum(pi_index_out)
    case default
       stop 'pi_index_sp: This normalization method is not implemented.'
    end select

#ifndef __PYTHON__
    if (present(counter)) then
       allocate(counter(npar))
       counter = my_counter
    end if

    if (present(evalues)) then
       allocate(evalues(npar))
       evalues = my_evalues
    end if

    if (present(evectors)) then
       allocate(evectors(npar,npar))
       evectors = my_evectors
    end if
#endif

    deallocate(my_counter)
    deallocate(my_evalues)
    deallocate(my_evectors)

  end subroutine pi_index_sp

END MODULE mo_pi_index


function modelA_function(in_val, out_val1, out_val2) result(out)
  real(kind=8), intent(in) :: in_val
  real(kind=8), intent(out) :: out_val1, out_val2
  logical :: out
  out = .true.
  out_val1 = 2 * in_val
  out_val2 = 3 * in_val
  write(*, '("modelA_function(",F10.5,") = (",F10.5,", ",F10.5,")")') in_val, out_val1, out_val2
end function modelA_function


!*==slalsd.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b SLALSD uses the singular value decomposition of A to solve the least squares problem.
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download SLALSD + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE SLALSD( UPLO, SMLSIZ, N, NRHS, D, E, B, LDB, RCOND,
!                          RANK, WORK, IWORK, INFO )
!
!       .. Scalar Arguments ..
!       CHARACTER          UPLO
!       INTEGER            INFO, LDB, N, NRHS, RANK, SMLSIZ
!       REAL               RCOND
!       ..
!       .. Array Arguments ..
!       INTEGER            IWORK( * )
!       REAL               B( LDB, * ), D( * ), E( * ), WORK( * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> SLALSD uses the singular value decomposition of A to solve the least
!> squares problem of finding X to minimize the Euclidean norm of each
!> column of A*X-B, where A is N-by-N upper bidiagonal, and X and B
!> are N-by-NRHS. The solution X overwrites B.
!>
!> The singular values of A smaller than RCOND times the largest
!> singular value are treated as zero in solving the least squares
!> problem; in this case a minimum norm solution is returned.
!> The actual singular values are returned in D in ascending order.
!>
!> This code makes very mild assumptions about floating point
!> arithmetic. It will work on machines with a guard digit in
!> add/subtract, or on those binary machines without guard digits
!> which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2.
!> It could conceivably fail on hexadecimal or decimal machines
!> without guard digits, but we know of none.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] UPLO
!> \verbatim
!>          UPLO is CHARACTER*1
!>         = 'U': D and E define an upper bidiagonal matrix.
!>         = 'L': D and E define a  lower bidiagonal matrix.
!> \endverbatim
!>
!> \param[in] SMLSIZ
!> \verbatim
!>          SMLSIZ is INTEGER
!>         The maximum size of the subproblems at the bottom of the
!>         computation tree.
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>         The dimension of the  bidiagonal matrix.  N >= 0.
!> \endverbatim
!>
!> \param[in] NRHS
!> \verbatim
!>          NRHS is INTEGER
!>         The number of columns of B. NRHS must be at least 1.
!> \endverbatim
!>
!> \param[in,out] D
!> \verbatim
!>          D is REAL array, dimension (N)
!>         On entry D contains the main diagonal of the bidiagonal
!>         matrix. On exit, if INFO = 0, D contains its singular values.
!> \endverbatim
!>
!> \param[in,out] E
!> \verbatim
!>          E is REAL array, dimension (N-1)
!>         Contains the super-diagonal entries of the bidiagonal matrix.
!>         On exit, E has been destroyed.
!> \endverbatim
!>
!> \param[in,out] B
!> \verbatim
!>          B is REAL array, dimension (LDB,NRHS)
!>         On input, B contains the right hand sides of the least
!>         squares problem. On output, B contains the solution X.
!> \endverbatim
!>
!> \param[in] LDB
!> \verbatim
!>          LDB is INTEGER
!>         The leading dimension of B in the calling subprogram.
!>         LDB must be at least max(1,N).
!> \endverbatim
!>
!> \param[in] RCOND
!> \verbatim
!>          RCOND is REAL
!>         The singular values of A less than or equal to RCOND times
!>         the largest singular value are treated as zero in solving
!>         the least squares problem. If RCOND is negative,
!>         machine precision is used instead.
!>         For example, if diag(S)*X=B were the least squares problem,
!>         where diag(S) is a diagonal matrix of singular values, the
!>         solution would be X(i) = B(i) / S(i) if S(i) is greater than
!>         RCOND*max(S), and X(i) = 0 if S(i) is less than or equal to
!>         RCOND*max(S).
!> \endverbatim
!>
!> \param[out] RANK
!> \verbatim
!>          RANK is INTEGER
!>         The number of singular values of A greater than RCOND times
!>         the largest singular value.
!> \endverbatim
!>
!> \param[out] WORK
!> \verbatim
!>          WORK is REAL array, dimension at least
!>         (9*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2),
!>         where NLVL = max(0, INT(log_2 (N/(SMLSIZ+1))) + 1).
!> \endverbatim
!>
!> \param[out] IWORK
!> \verbatim
!>          IWORK is INTEGER array, dimension at least
!>         (3*N*NLVL + 11*N)
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>         = 0:  successful exit.
!>         < 0:  if INFO = -i, the i-th argument had an illegal value.
!>         > 0:  The algorithm failed to compute a singular value while
!>               working on the submatrix lying in rows and columns
!>               INFO/(N+1) through MOD(INFO,N+1).
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup realOTHERcomputational
!
!> \par Contributors:
!  ==================
!>
!>     Ming Gu and Ren-Cang Li, Computer Science Division, University of
!>       California at Berkeley, USA \n
!>     Osni Marques, LBNL/NERSC, USA \n
!
!  =====================================================================
      SUBROUTINE SLALSD(Uplo,Smlsiz,N,Nrhs,D,E,B,Ldb,Rcond,Rank,Work,   &
     &                  Iwork,Info)
      IMPLICIT NONE
!*--SLALSD183
!
!  -- LAPACK computational routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     December 2016
!
!     .. Scalar Arguments ..
      CHARACTER Uplo
      INTEGER Info , Ldb , N , Nrhs , Rank , Smlsiz
      REAL Rcond
!     ..
!     .. Array Arguments ..
      INTEGER Iwork(*)
      REAL B(Ldb,*) , D(*) , E(*) , Work(*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      REAL ZERO , ONE , TWO
      PARAMETER (ZERO=0.0E0,ONE=1.0E0,TWO=2.0E0)
!     ..
!     .. Local Scalars ..
      INTEGER bx , bxst , c , difl , difr , givcol , givnum , givptr ,  &
     &        i , icmpq1 , icmpq2 , iwk , j , k , nlvl , nm1 , nsize ,  &
     &        nsub , nwork , perm , poles , s , sizei , smlszp , sqre , &
     &        st , st1 , u , vt , z
      REAL cs , eps , orgnrm , r , rcnd , sn , tol
!     ..
!     .. External Functions ..
      INTEGER ISAMAX
      REAL SLAMCH , SLANST
      EXTERNAL ISAMAX , SLAMCH , SLANST
!     ..
!     .. External Subroutines ..
      EXTERNAL SCOPY , SGEMM , SLACPY , SLALSA , SLARTG , SLASCL ,      &
     &         SLASDA , SLASDQ , SLASET , SLASRT , SROT , XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC ABS , INT , LOG , REAL , SIGN
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      Info = 0
!
      IF ( N<0 ) THEN
         Info = -3
      ELSEIF ( Nrhs<1 ) THEN
         Info = -4
      ELSEIF ( (Ldb<1) .OR. (Ldb<N) ) THEN
         Info = -8
      ENDIF
      IF ( Info/=0 ) THEN
         CALL XERBLA('SLALSD',-Info)
         RETURN
      ENDIF
!
      eps = SLAMCH('Epsilon')
!
!     Set up the tolerance.
!
      IF ( (Rcond<=ZERO) .OR. (Rcond>=ONE) ) THEN
         rcnd = eps
      ELSE
         rcnd = Rcond
      ENDIF
!
      Rank = 0
!
!     Quick return if possible.
!
      IF ( N==0 ) THEN
         RETURN
      ELSEIF ( N==1 ) THEN
         IF ( D(1)==ZERO ) THEN
            CALL SLASET('A',1,Nrhs,ZERO,ZERO,B,Ldb)
         ELSE
            Rank = 1
            CALL SLASCL('G',0,0,D(1),ONE,1,Nrhs,B,Ldb,Info)
            D(1) = ABS(D(1))
         ENDIF
         RETURN
      ENDIF
!
!     Rotate the matrix if it is lower bidiagonal.
!
      IF ( Uplo=='L' ) THEN
         DO i = 1 , N - 1
            CALL SLARTG(D(i),E(i),cs,sn,r)
            D(i) = r
            E(i) = sn*D(i+1)
            D(i+1) = cs*D(i+1)
            IF ( Nrhs==1 ) THEN
               CALL SROT(1,B(i,1),1,B(i+1,1),1,cs,sn)
            ELSE
               Work(i*2-1) = cs
               Work(i*2) = sn
            ENDIF
         ENDDO
         IF ( Nrhs>1 ) THEN
            DO i = 1 , Nrhs
               DO j = 1 , N - 1
                  cs = Work(j*2-1)
                  sn = Work(j*2)
                  CALL SROT(1,B(j,i),1,B(j+1,i),1,cs,sn)
               ENDDO
            ENDDO
         ENDIF
      ENDIF
!
!     Scale.
!
      nm1 = N - 1
      orgnrm = SLANST('M',N,D,E)
      IF ( orgnrm==ZERO ) THEN
         CALL SLASET('A',N,Nrhs,ZERO,ZERO,B,Ldb)
         RETURN
      ENDIF
!
      CALL SLASCL('G',0,0,orgnrm,ONE,N,1,D,N,Info)
      CALL SLASCL('G',0,0,orgnrm,ONE,nm1,1,E,nm1,Info)
!
!     If N is smaller than the minimum divide size SMLSIZ, then solve
!     the problem with another solver.
!
      IF ( N<=Smlsiz ) THEN
         nwork = 1 + N*N
         CALL SLASET('A',N,N,ZERO,ONE,Work,N)
         CALL SLASDQ('U',0,N,N,0,Nrhs,D,E,Work,N,Work,N,B,Ldb,          &
     &               Work(nwork),Info)
         IF ( Info/=0 ) RETURN
         tol = rcnd*ABS(D(ISAMAX(N,D,1)))
         DO i = 1 , N
            IF ( D(i)<=tol ) THEN
               CALL SLASET('A',1,Nrhs,ZERO,ZERO,B(i,1),Ldb)
            ELSE
               CALL SLASCL('G',0,0,D(i),ONE,1,Nrhs,B(i,1),Ldb,Info)
               Rank = Rank + 1
            ENDIF
         ENDDO
         CALL SGEMM('T','N',N,Nrhs,N,ONE,Work,N,B,Ldb,ZERO,Work(nwork), &
     &              N)
         CALL SLACPY('A',N,Nrhs,Work(nwork),N,B,Ldb)
!
!        Unscale.
!
         CALL SLASCL('G',0,0,ONE,orgnrm,N,1,D,N,Info)
         CALL SLASRT('D',N,D,Info)
         CALL SLASCL('G',0,0,orgnrm,ONE,N,Nrhs,B,Ldb,Info)
!
         RETURN
      ENDIF
!
!     Book-keeping and setting up some constants.
!
      nlvl = INT(LOG(REAL(N)/REAL(Smlsiz+1))/LOG(TWO)) + 1
!
      smlszp = Smlsiz + 1
!
      u = 1
      vt = 1 + Smlsiz*N
      difl = vt + smlszp*N
      difr = difl + nlvl*N
      z = difr + nlvl*N*2
      c = z + nlvl*N
      s = c + N
      poles = s + N
      givnum = poles + 2*nlvl*N
      bx = givnum + 2*nlvl*N
      nwork = bx + N*Nrhs
!
      sizei = 1 + N
      k = sizei + N
      givptr = k + N
      perm = givptr + N
      givcol = perm + nlvl*N
      iwk = givcol + nlvl*N*2
!
      st = 1
      sqre = 0
      icmpq1 = 1
      icmpq2 = 0
      nsub = 0
!
      DO i = 1 , N
         IF ( ABS(D(i))<eps ) D(i) = SIGN(eps,D(i))
      ENDDO
!
      DO i = 1 , nm1
         IF ( (ABS(E(i))<eps) .OR. (i==nm1) ) THEN
            nsub = nsub + 1
            Iwork(nsub) = st
!
!           Subproblem found. First determine its size and then
!           apply divide and conquer on it.
!
            IF ( i<nm1 ) THEN
!
!              A subproblem with E(I) small for I < NM1.
!
               nsize = i - st + 1
               Iwork(sizei+nsub-1) = nsize
            ELSEIF ( ABS(E(i))>=eps ) THEN
!
!              A subproblem with E(NM1) not too small but I = NM1.
!
               nsize = N - st + 1
               Iwork(sizei+nsub-1) = nsize
            ELSE
!
!              A subproblem with E(NM1) small. This implies an
!              1-by-1 subproblem at D(N), which is not solved
!              explicitly.
!
               nsize = i - st + 1
               Iwork(sizei+nsub-1) = nsize
               nsub = nsub + 1
               Iwork(nsub) = N
               Iwork(sizei+nsub-1) = 1
               CALL SCOPY(Nrhs,B(N,1),Ldb,Work(bx+nm1),N)
            ENDIF
            st1 = st - 1
            IF ( nsize==1 ) THEN
!
!              This is a 1-by-1 subproblem and is not solved
!              explicitly.
!
               CALL SCOPY(Nrhs,B(st,1),Ldb,Work(bx+st1),N)
            ELSEIF ( nsize<=Smlsiz ) THEN
!
!              This is a small subproblem and is solved by SLASDQ.
!
               CALL SLASET('A',nsize,nsize,ZERO,ONE,Work(vt+st1),N)
               CALL SLASDQ('U',0,nsize,nsize,0,Nrhs,D(st),E(st),        &
     &                     Work(vt+st1),N,Work(nwork),N,B(st,1),Ldb,    &
     &                     Work(nwork),Info)
               IF ( Info/=0 ) RETURN
               CALL SLACPY('A',nsize,Nrhs,B(st,1),Ldb,Work(bx+st1),N)
            ELSE
!
!              A large problem. Solve it using divide and conquer.
!
               CALL SLASDA(icmpq1,Smlsiz,nsize,sqre,D(st),E(st),        &
     &                     Work(u+st1),N,Work(vt+st1),Iwork(k+st1),     &
     &                     Work(difl+st1),Work(difr+st1),Work(z+st1),   &
     &                     Work(poles+st1),Iwork(givptr+st1),           &
     &                     Iwork(givcol+st1),N,Iwork(perm+st1),         &
     &                     Work(givnum+st1),Work(c+st1),Work(s+st1),    &
     &                     Work(nwork),Iwork(iwk),Info)
               IF ( Info/=0 ) RETURN
               bxst = bx + st1
               CALL SLALSA(icmpq2,Smlsiz,nsize,Nrhs,B(st,1),Ldb,        &
     &                     Work(bxst),N,Work(u+st1),N,Work(vt+st1),     &
     &                     Iwork(k+st1),Work(difl+st1),Work(difr+st1),  &
     &                     Work(z+st1),Work(poles+st1),Iwork(givptr+st1)&
     &                     ,Iwork(givcol+st1),N,Iwork(perm+st1),        &
     &                     Work(givnum+st1),Work(c+st1),Work(s+st1),    &
     &                     Work(nwork),Iwork(iwk),Info)
               IF ( Info/=0 ) RETURN
            ENDIF
            st = i + 1
         ENDIF
      ENDDO
!
!     Apply the singular values and treat the tiny ones as zero.
!
      tol = rcnd*ABS(D(ISAMAX(N,D,1)))
!
      DO i = 1 , N
!
!        Some of the elements in D can be negative because 1-by-1
!        subproblems were not solved explicitly.
!
         IF ( ABS(D(i))<=tol ) THEN
            CALL SLASET('A',1,Nrhs,ZERO,ZERO,Work(bx+i-1),N)
         ELSE
            Rank = Rank + 1
            CALL SLASCL('G',0,0,D(i),ONE,1,Nrhs,Work(bx+i-1),N,Info)
         ENDIF
         D(i) = ABS(D(i))
      ENDDO
!
!     Now apply back the right singular vectors.
!
      icmpq2 = 1
      DO i = 1 , nsub
         st = Iwork(i)
         st1 = st - 1
         nsize = Iwork(sizei+i-1)
         bxst = bx + st1
         IF ( nsize==1 ) THEN
            CALL SCOPY(Nrhs,Work(bxst),N,B(st,1),Ldb)
         ELSEIF ( nsize<=Smlsiz ) THEN
            CALL SGEMM('T','N',nsize,Nrhs,nsize,ONE,Work(vt+st1),N,     &
     &                 Work(bxst),N,ZERO,B(st,1),Ldb)
         ELSE
            CALL SLALSA(icmpq2,Smlsiz,nsize,Nrhs,Work(bxst),N,B(st,1),  &
     &                  Ldb,Work(u+st1),N,Work(vt+st1),Iwork(k+st1),    &
     &                  Work(difl+st1),Work(difr+st1),Work(z+st1),      &
     &                  Work(poles+st1),Iwork(givptr+st1),              &
     &                  Iwork(givcol+st1),N,Iwork(perm+st1),            &
     &                  Work(givnum+st1),Work(c+st1),Work(s+st1),       &
     &                  Work(nwork),Iwork(iwk),Info)
            IF ( Info/=0 ) RETURN
         ENDIF
      ENDDO
!
!     Unscale and sort the singular values.
!
      CALL SLASCL('G',0,0,ONE,orgnrm,N,1,D,N,Info)
      CALL SLASRT('D',N,D,Info)
      CALL SLASCL('G',0,0,orgnrm,ONE,N,Nrhs,B,Ldb,Info)
!
!
!     End of SLALSD
!
      END SUBROUTINE SLALSD


! data are 348 monthly values (29 years) in file stl_co2
! gfortran stl-fixed.f90 stl_test_data.f90 -o stl_test
! ./stl_test < co2 > stl_test_results.csv
real(kind=8) y(348), season(348), trend(348), rw(348), work(372, 7), &
             y_short(347), season_short(347), trend_short(347), rw_short(347), &
             work_short(371, 7)
logical robust, ok, userw
read(5, *)(y(i), i = 1, 348)

print *, "scenario,idx,season,trend,rw"

n = 348
np = 12
ns = 35
nt = 19
nl = 13
no = 2
ni = 1
nsjump = 4
ntjump = 2
nljump = 2
isdeg = 1
itdeg = 1
ildeg = 1
trend = 0.0
season = 0.0
rw = 1.0
work = 0.0
call stl(y, n, np, ns, nt, nl, isdeg, itdeg, ildeg, nsjump, ntjump, &
         nljump, ni, no, rw, season, trend, work)
do i = 1, n
    print *, "baseline,", i-1, ",", season(i), ",", trend(i), ",", rw(i)
end do

nljump = 1
trend = 0.0
season = 0.0
rw = 1.0
work = 0.0
call stl(y, n, np, ns, nt, nl, isdeg, itdeg, ildeg, nsjump, ntjump, &
         nljump, ni, no, rw, season, trend, work)
do i = 1, n
    print *, "nljump-1,", i-1, ",", season(i), ",", trend(i), ",", rw(i)
end do

nljump = 2
ntjump = 1
trend = 0.0
season = 0.0
rw = 1.0
work = 0.0
call stl(y, n, np, ns, nt, nl, isdeg, itdeg, ildeg, nsjump, ntjump, &
         nljump, ni, no, rw, season, trend, work)
do i = 1, n
    print *, "ntjump-1,", i-1, ",", season(i), ",", trend(i), ",", rw(i)
end do

rw = 1.0
nljump = 1
ntjump = 1
trend = 0.0
season = 0.0
rw = 1.0
work = 0.0
call stl(y, n, np, ns, nt, nl, isdeg, itdeg, ildeg, nsjump, ntjump, &
         nljump, ni, no, rw, season, trend, work)
do i = 1, n
    print *, "nljump-1-ntjump-1,", i-1, ",", season(i), ",", trend(i), ",", rw(i)
end do

do i = 1, n-1
    y_short(i) = y(i)
end do
ntjump = 2
nljump = 2
rw_short = 1.0
trend_short = 0.0
season_short = 0.0
work_short = 0.0
call stl(y_short, n-1, np, ns, nt, nl, isdeg, itdeg, ildeg, nsjump, ntjump, &
         nljump, ni, no, rw_short, season_short, trend_short, work_short)
do i = 1, n-1
    print *, "short,", i-1, ",", season_short(i), ",", trend_short(i), ",", rw_short(i)
end do

season = 0.0
trend = 0.0
rw = 1.0
robust = .false.
call stlez(y, n, np, ns, isdeg, itdeg, robust, nconv, rw, season, trend, work)
do i = 1, n
    print *, "stlez,", i-1, ",", season(i), ",", trend(i), ",", rw(i)
end do

season = 0.0
trend = 0.0
rw = 1.0
robust = .true.
call stlez(y, n, np, ns, isdeg, itdeg, robust, nconv, rw, season, trend, work)
do i = 1, n
    print *, "stlez-robust,", i-1, ",", season(i), ",", trend(i), ",", rw(i)
end do

end


./sim_define.v

//////// RTL ///////////////////

+incdir+../../src/rtl
../../src/rtl/full_adder.v
../../src/rtl/ripple_carry_adder_16.v
../../src/rtl/cla_4bit.v
../../src/rtl/cla_logic.v
../../src/rtl/carry_lookahead_adder_16.v
../../src/rtl/adder_top.v

../../testbench/testbench.v


PROGRAM p16

    IMPLICIT NONE
    INTEGER, PARAMETER :: st=8
    INTEGER :: row, col, r
    REAL, DIMENSION(2:10, -30:30, 0:10) :: t,y,t_by_y
    COMPLEX, DIMENSION (1:10, 2+st) :: z,c

    COMPLEX, DIMENSION(1:5) :: a

    t=2.0
    y=3.0
    t_by_y = t*y

!    PRINT *,t_by_y

    z = (1.0, 0.0)

!    PRINT *, "z"
!    PRINT *, z

    DO r=1,10
        z(1,r) = (0.0, 9.0)
    END DO

    PRINT *, "z"
    PRINT *, z

    c=(2.0, 0.0) * z + (1.0, 0.0)

    PRINT *, "c(1:3, 8:10)"
    PRINT *, c(1:3, 8:10)

    a = (1.0, 2.0)

    print *, "a"
    print *, a

END PROGRAM p16


!
! wavy - A spectral ocean wave modeling and development framework
! Copyright (c) 2017, Wavebit Scientific LLC
! All rights reserved.
!
! Licensed under the BSD-3 clause license. See LICENSE for details.
!
program test_time_integration_spectrum

use mod_const
use mod_precision,only:rk => realkind
use mod_spectrum,only:spectrum_type
use mod_spectral_shapes,only:jonswap
use mod_source_functions,only:sin_DCCM2012,sds_DCCM2012,sdt_DCCM2012,snl_DCCM2012
use mod_time_integration,only:forward_euler,exact_exponential,backward_euler

implicit none

type(spectrum_type) :: spec,spec2,sin_tend,sds_tend,sdt_tend,snl_tend
real(kind=rk) :: wspd
real(kind=rk) :: fetch
real(kind=rk),parameter :: grav = 9.8_rk
integer :: m,n,stat

write(*,*)
write(*,*)'Initialize omnidirectional spectrum with JONSWAP shape;'
write(*,*)

wspd = 1e1_rk
fetch = 1e5_rk

! Initialize spectrum
spec = spectrum_type(fmin=0.0313_rk,fmax=2._rk,df=1.1_rk,ndirs=1,depth=1e3_rk)
spec = jonswap(spec % getFrequency(),wspd=wspd,fetch=fetch,grav=grav)

spec2 = spectrum_type(fmin=0.0313_rk,fmax=2._rk,df=1.1_rk,ndirs=1,depth=1e3_rk)

call spec % writeJSON('spectrum.json',minify=.false.)
call spec2 % readJSON('spectrum.json')
call spec % writeJSON('spectrum2.json',minify=.false.)

write(*,*)spec == spec2
write(*,*)all(spec % getSpectrum() == spec2 % getSpectrum())

write(*,fmt='(a)')'   wspd      Hs      Tp       Tm1      Tm2      mss'&
                //'      m0(f)    m1(f)    m2(f)'
write(*,fmt='(a)')'----------------------------------------------------------'&
                //'----------------------'
do n = 1,61

  write(*,fmt='(9(f8.4,1x))')wspd,spec % significantWaveHeight(),&
    1./spec % peakFrequency(),spec % meanPeriod(),&
    spec % meanPeriodZeroCrossing(),spec % meanSquareSlope(),&
    spec % frequencyMoment(0),spec % frequencyMoment(1),&
    spec % frequencyMoment(2)

  sin_tend = sin_DCCM2012(spectrum=spec,wspd=wspd,wdir=0._rk,input_height=10._rk,&
                          ustar=1e-2_rk,vonkarman=0.4_rk)
  sds_tend = sds_DCCM2012(spec,42._rk,2.5_rk,120._rk)
  sdt_tend = sdt_DCCM2012(spec,1e-2_rk,1e-2_rk)
  snl_tend = snl_DCCM2012(spec,sds_tend,0.005_rk)

  !spec = forward_euler(spec,(sin_tend-sds_tend-sdt_tend)*spec,dt=60._rk)
  !spec = backward_euler(spec,(sin_tend-sds_tend-sdt_tend)*spec,dt=60._rk)
  spec = exact_exponential(spec,sin_tend-sds_tend-sdt_tend+snl_tend,dt=60._rk)
  !spec = exact_exponential(spec,sin_tend-sds_tend-sdt_tend,dt=60._rk)

enddo

endprogram test_time_integration_spectrum


      subroutine qlI3sub(msq,psq,musq,Ival)
C Calculates the general scalar triangle
C assumes that the msq(i) are positive and ordered
C so that msq(1) .le. msq(2) .le. msq(3)
      implicit none
      include 'qlconstants.f'
      double precision msq(3),psq(3),musq,Y(3,3),xpi(6)
      double complex Ival(-2:0)
      integer j,massive,ier
      logical qlzero, qlnonzero

      do j=1,3
      xpi(j)=msq(j)
      xpi(j+3)=psq(j)
      Y(j,j)=msq(j)
      enddo
      Y(1,2)=0.5d0*(msq(1)+msq(2)-psq(1))
      Y(1,3)=0.5d0*(msq(1)+msq(3)-psq(3))
      Y(2,3)=0.5d0*(msq(2)+msq(3)-psq(2))
      Y(2,1)=Y(1,2)
      Y(3,1)=Y(1,3)
      Y(3,2)=Y(2,3)

      massive=0
      do j=1,3
      if (qlnonzero(abs(msq(j)))) massive=massive+1
      enddo

      Ival(-2)=czip
      Ival(-1)=czip

C--------------three internal masses
      if (massive .eq. 3) then
               call qlI3fin(Ival(0),xpi,ier)

C--------------two internal masses
      elseif (massive .eq. 2) then
           if   (qlzero(abs(Y(1,2)))
     .     .and. qlzero(abs(Y(1,3)))) then
                call qltri6(psq(2),msq(2),msq(3),musq,Ival)
            else
                call qlI3fin(Ival(0),xpi,ier)
            endif

C--------------one internal masses
      elseif (massive .eq. 1) then
           if       (qlnonzero(abs(Y(1,2)))) then
                call qlI3fin(Ival(0),xpi,ier)
           else
                if (qlzero(abs(Y(1,3))) .and.
     .         qlzero(abs(Y(2,3)))) then
                      call qltri5(msq(3),musq,Ival)
                elseif (qlzero(abs(Y(1,3)))) then
                      call qltri4(psq(2),msq(3),musq,Ival)
                elseif (qlzero(abs(Y(2,3)))) then
                      call qltri4(psq(3),msq(3),musq,Ival)
                else
                      call qltri3(psq(2),psq(3),msq(3),musq,Ival)
                endif
           endif
C--------------qlzero internal masses
      elseif (massive .eq. 0) then
           if     (qlzero(abs(Y(1,2))) .and.
     .    qlzero(abs(Y(2,3)))) then
                  call qltri1(psq(3),musq,Ival)
           elseif  (qlzero(abs(Y(1,2)))) then
                 call qltri2(psq(2),psq(3),musq,Ival)
           else
                 call qlI3fin(Ival(0),xpi,ier)
           endif
      endif
      return
      end


! This example maps over an entire array to the GPU, then launches kernels to update sections of the array.
! It uses target update on those sections as each kernel finishes.
program daxpy_array_slices
   implicit none

   integer i, j, num_slices, num_values, a
   real, pointer, contiguous, dimension(:,:) :: x, y

   a = 5
   num_slices = 10
   num_values = 1024

   allocate(x(num_values,num_slices))
   allocate(y(num_values,num_slices))

   ! initialize arrays
   do j = 1, num_slices
      x(:,j) = DBLE(j)
      y(:,j) = DBLE(j)
   end do

   do j = 1, num_slices
      print *, "----------"
      print *, "before x(1:10,", j, ") ", x(1:10,j)
      print *, "----------"
   end do

   !$omp target data map(alloc:x, y)

   !$omp parallel do
   do j = 1, num_slices

      !$omp target update to(x(:,j), y(:,j))

! NOTE - not sure the additional map on the teams line is needed.  Added it so
! the runtime knows that we've mapped over the array slice needed and to not
! perform any implicit map of x or y.
      !$omp target teams distribute parallel do private(i) shared(a, x, y, j, num_values) map(alloc:x(:,j), y(:,j)) default(none)
      do i = 1, num_values
         x(i,j) = a*x(i,j) + y(i,j)
      end do
      !$omp end target teams distribute parallel do

      print *, "Ran daxpy on slice ", j
      !$omp target update from(x(:,j), y(:,j))
   end do
   !$omp end parallel do

   !$omp end target data

   do j = 1, num_slices
      print *, "----------"
      print *, "after x(1:10,", j, ") ", x(1:10,j)
      print *, "----------"
   end do

end program daxpy_array_slices


program gemv_vs_trmv
    use, intrinsic :: iso_fortran_env, only : error_unit
    implicit none
    integer :: n, runs, run, i, istat
    real, dimension(:, :), allocatable :: matrix
    real, dimension(:), allocatable :: vector, orig_vector, tmp_vector, &
                                       tr_result, ge_result
    real :: start_time, end_time

    call get_arguments(runs, n)
    allocate (matrix(n, n), vector(n), orig_vector(n), tmp_vector(n), &
              tr_result(n), ge_result(n), stat=istat)
    if (istat /= 0) then
        write (unit=error_unit, fmt='(A)') 'error: can not allocate data'
        stop 2
    end if
    do i = 1, n
        matrix(i, 1: i - 1) = 0.0
        call random_number(matrix(i, i:n))
    end do
    call random_number(vector)
    call scopy(size(vector), vector, 1, orig_vector, 1)

    ! vector = matrix*vector
    print '(A)', 'strmv'
    call cpu_time(start_time)
    do run = 1, runs
        call strmv('u', 'n', 'n', size(matrix, 2), matrix, size(matrix, 1), &
                   vector, 1)
    end do
    call cpu_time(end_time)
    print '(A10, F10.6)', 'strmv: ', end_time - start_time
    call scopy(size(vector), vector, 1, tr_result, 1)

    print '(A)', 'sgemv'
    call scopy(size(vector), orig_vector, 1, vector, 1)
    call cpu_time(start_time)
    do run = 1, runs, 2
        call sgemv('n', size(matrix, 1), size(matrix, 2), &
                   1.0, matrix, size(matrix, 1), vector, 1, &
                   0.0, tmp_vector, 1)
        call sgemv('n', size(matrix, 1), size(matrix, 2), &
                   1.0, matrix, size(matrix, 1), tmp_vector, 1, &
                   0.0, vector, 1)
    end do
    if (mod(runs, 2) /= 0) then
        call sgemv('n', size(matrix, 1), size(matrix, 2), &
                   1.0, matrix, size(matrix, 1), vector, 1, &
                   0.0, tmp_vector, 1)
    call scopy(size(vector), tmp_vector, 1, vector, 1)
    end if
    call cpu_time(end_time)
    print '(A10, F10.6)', 'sgemv: ', end_time - start_time
    call scopy(size(vector), vector, 1, ge_result, 1)

    if (all(abs(tr_result - ge_result) > 1.0e04)) then
        print '(A)', 'differences!'
        stop 3
    end if

    deallocate (matrix, vector, orig_vector, tmp_vector)

contains

    subroutine get_arguments(runs, n)
        use, intrinsic :: iso_fortran_env, only : error_unit
        implicit none
        integer, intent(out) :: runs, n
        integer :: istat
        character(len=1024) :: buffer, msg

        runs = 1
        if (command_argument_count() >= 1) then
            call get_command_argument(1, buffer)
            read (buffer, fmt=*, iostat=istat, iomsg=msg) runs
            if (istat /= 0) then
                write (unit=error_unit, fmt='(2A)') 'error: ', trim(msg)
                stop 1
            end if
        end if
        n = 500
        if (command_argument_count() >= 2) then
            call get_command_argument(2, buffer)
            read (buffer, fmt=*) n
            if (istat /= 0) then
                write (unit=error_unit, fmt='(2A)') 'error: ', trim(msg)
                stop 1
            end if
        end if
    end subroutine get_arguments

end program gemv_vs_trmv


! { dg-do run }
!
! Test the fix for PR35824, in which the interface assignment and
! negation did not work correctly.
!
! Contributed by Rolf Roth <everyo@gmx.net>
!
module typemodule
  type alltype
     double precision :: a
     double precision,allocatable :: b(:)
  end type
  interface assignment(=)
    module procedure at_from_at
  end interface
  interface operator(-)
    module procedure  neg_at
  end interface
contains
  subroutine at_from_at(b,a)
    type(alltype), intent(in) :: a
    type(alltype), intent(out) :: b
    b%a=a%a
    allocate(b%b(2))
    b%b=a%b
  end subroutine at_from_at
  function neg_at(a) result(b)
    type(alltype), intent(in) :: a
    type(alltype) :: b
    b%a=-a%a
    allocate(b%b(2))
    b%b=-a%b
  end function neg_at
end module
  use typemodule
  type(alltype) t1,t2,t3
  allocate(t1%b(2))
  t1%a=0.5d0
  t1%b(1)=1d0
  t1%b(2)=2d0
  t2=-t1
  if (t2%a .ne. -0.5d0) STOP 1
  if (any(t2%b .ne. [-1d0, -2d0])) STOP 2

  t1=-t1
  if (t1%a .ne. -0.5d0) STOP 3
  if (any(t1%b .ne. [-1d0, -2d0])) STOP 4
end


    module precision
      integer, parameter  :: sp=selected_real_kind(6)
      integer, parameter  :: dp=selected_real_kind(13)
      integer, parameter  :: qp=selected_real_kind(21)
    end module precision


subroutine get_true_solution_by_index_range(i_low, i_high, t, values)

    implicit none

    integer :: mx, mbc, meqn
    double precision :: x_lower, dx
    common /claw_config/ mx, mbc, x_lower, dx, meqn

    integer, intent(in) :: i_low, i_high
    double precision, intent(in) :: t
    double precision, dimension(i_low:i_high) :: values

    integer :: i
    double precision :: x
    double precision, external :: true_solution

    do i = i_low, i_high
        x = x_lower + (i - .5d0) * dx
        values(i) = true_solution(x, t)
    end do

end subroutine get_true_solution_by_index_range


module subroutines_07_mod

    interface f_int
        procedure f
    end interface

contains

    subroutine f(a, b, c, d, kind)
        integer, intent(in) :: a, d, c
        integer, intent(in), optional :: kind
        integer, intent(out) :: b
        b = a + 1 + c + d
    end subroutine

end module

program subroutines_07
    use subroutines_07_mod
    implicit none
    integer :: i, j, k, l
    i = 1
    j = 1
    k = 1
    l = 1
    call f_int(i, j, k, l)
    if (j /= 4) error stop

end program


!* 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

!   REAL with complex arguments and with/without KIND argument

program accuracy
  implicit none
  complex(kind=8)   :: z8
  complex(kind=4)   :: z4
  real(kind=8)      :: result(8), expect(8)
  data expect/ 0.5555555555555556d0,0.5555555555555556d0,0.5555555555555556d0, &
	       0.5555555820465088d0,0.5555555820465088d0,0.5555555820465088d0, &
	       0.5555555820465088d0,0.5555555820465088d0/

  z8 = (0.5555555555555555555555555d0,0.55555555555555555555555d0)
  result(1) = real(z8)
  result(2) = dreal(z8)
  result(3) = real(z8,kind=8)
  result(4) = real(z8,kind=4)
  z4 = (0.5555555555555555555555555e0,0.55555555555555555555555e0)
  result(5) = real(z4)
  result(6) = dreal(z4)
  result(7) = real(z4,kind=8)
  result(8) = real(z4,kind=4)
!  print *,result
!  print *,expect
  call check(result,expect,16)
end program accuracy


PROGRAM Sedov_SphericalSymmetry

  USE KindModule, ONLY: &
    DP, Pi
  USE ProgramInitializationModule, ONLY: &
    InitializeProgram, &
    FinalizeProgram
  USE RiemannProblemInitializationModule, ONLY: &
    InitializeSedov
  USE TimeSteppingModule, ONLY: &
    EvolveFields, &
    SSP_RK

  IMPLICIT NONE

  CALL InitializeProgram &
         ( ProgramName_Option &
            = 'Sedov_SphericalSymmetry', &
           nX_Option &
             = [ 1024, 1, 1 ], &
           swX_Option &
             = [ 1, 0, 0 ], &
           bcX_Option &
             = [ 2, 0, 0 ], &
           xL_Option &
             = [ 0.0_DP, 0.0_DP, 0.0_DP ], &
           xR_Option &
             = [ 1.2_DP, Pi,     4.0_DP ], &
           nNodes_Option &
             = 1, &
           CoordinateSystem_Option &
             = 'SPHERICAL', &
           EquationOfState_Option &
             = 'IDEAL', &
           Gamma_IDEAL_Option &
             = 1.4_DP, &
           FluidSolver_Option &
             = 'Euler_DG', &
           FluidRiemannSolver_Option &
             = 'HLLC', &
           EvolveFluid_Option &
             = .TRUE., &
           ApplySlopeLimiter_Option &
             = .TRUE., &
           BetaTVB_Option &
             = 1.0d2, &
           BetaTVD_Option &
             = 2.0d0, &
           ApplyPositivityLimiter_Option &
             = .TRUE., &
           nStages_SSP_RK_Option &
             = 1 )

  CALL InitializeSedov( E_0 = 1.0_DP, nDetonationCells_Option = 3 )

  CALL EvolveFields &
         ( t_begin  = 0.00_DP, &
           t_end    = 1.00_DP, &
           dt_write = 0.05_DP, &
           UpdateFields = SSP_RK )

  CALL FinalizeProgram

END PROGRAM Sedov_SphericalSymmetry