module timestepper_module

  use inputs_module
  use outputs_module
  use element_module
  use solvergmres_module

  implicit none

contains
  !========================================================================================================
  subroutine timestepping_Explicit(inpobj,elementarray,pointsoln,interpsoln)

    type(inputdata), intent(inout)  :: inpobj
    type(element), intent(inout) :: elementarray(:)
    real*8                       :: l2norm(globalnumeq),totaltime,printtime
    integer                      :: iterations,df,i,neq,printit
    logical                      :: isitRK
    integer                      :: numstages
    integer                      :: rkstage
    real*8                       :: multiplier
    real*8,allocatable           :: pointsoln(:,:)
    real*8,allocatable           :: interpsoln(:,:)

    if(inpobj%timeorder > 1) then
	    isitRK = .true.
	    numstages = 5
    else
    	    isitRK = .false.
            numstages = 1
    endif

    call printsolution(elementarray,inpobj%nelements,0,inpobj%printpointsperelement,&
		    inpobj%xscale,inpobj%scalefactors,pointsoln)
    call printpolysolution(elementarray,inpobj%nelements,0,inpobj%printpointsperelement,&
		    inpobj%xscale,inpobj%scalefactors,interpsoln)
    totaltime  = 0.d0
    printtime  = 0.d0
    iterations = 0
    printit    = 1

    do while(totaltime < inpobj%finaltime)

       totaltime  = totaltime  + inpobj%timestep
       printtime  = printtime  + inpobj%timestep
       iterations = iterations + 1

       call applydirichletbc(elementarray(inpobj%nelements),inpobj)

       !save prvs soln if RK
       do i=1,inpobj%nelements
	      call saveprvssoln(elementarray(i))
       enddo

	if(isitRK) then

		do rkstage=1,numstages
			multiplier=rkcoeffs(rkstage)
			call compute_explicitrhs(elementarray,inpobj,totaltime)
			call dotimestep_explicit(elementarray,inpobj,multiplier)
			print *,"rkstage:",rkstage
		enddo

	else
		multiplier=1.d0
		call compute_explicitrhs(elementarray,inpobj,totaltime)
		call dotimestep_explicit(elementarray,inpobj,multiplier)
	endif

       call calc_l2norm_of_residual(elementarray,inpobj%nelements,l2norm)

       do i=1,globalnumeq
          write(*,'(F18.11)',advance='no')l2norm(i)
       enddo
       write(*,'(F18.11)',advance='yes')

       if(printtime*inpobj%tscale .ge. inpobj%printtime) then

	call printsolution(elementarray,inpobj%nelements,printit,inpobj%printpointsperelement,&
			inpobj%xscale,inpobj%scalefactors,pointsoln)

    	call printpolysolution(elementarray,inpobj%nelements,printit,inpobj%printpointsperelement,&
			inpobj%xscale,inpobj%scalefactors,interpsoln)

	print *
	print *,"saving solution at time:",totaltime
	printtime=0.d0
	printit=printit+1

	endif

       print *,"totaltime:",totaltime*inpobj%tscale,"iterations:",iterations
       print *,"======================================="

    enddo

    print *,"final time:",totaltime*inpobj%tscale
    call printsolution(elementarray,inpobj%nelements,printit,inpobj%printpointsperelement,&
		    inpobj%xscale,inpobj%scalefactors,pointsoln)
    call printpolysolution(elementarray,inpobj%nelements,printit,inpobj%printpointsperelement,&
		    inpobj%xscale,inpobj%scalefactors,interpsoln)

  end subroutine timestepping_Explicit
  !========================================================================================================
  subroutine compute_explicitrhs(elementarray,inpobj,totaltime)

    type(inputdata), intent(inout)  :: inpobj
    type(element), intent(inout) :: elementarray(:)
    real*8, intent(in) :: totaltime
    integer :: i,neq

      !boundary contributions
       do i=1,inpobj%nelements

          call computemassmatX(elementarray(i),inpobj,totaltime)
          call computediffmatX(elementarray(i),elementarray(i)%solnvec,inpobj,totaltime)

       enddo
       !      found residuals and mass matrix

       ! update residuals at internal boundaries
       do i=1,inpobj%nelements-1

          do neq=1,globalnumeq

             elementarray(i)%residual(elementarray(i)%p+1,neq) = elementarray(i)%residual(elementarray(i)%p+1,neq) + &
                  elementarray(i+1)%residual(1,neq)
             elementarray(i+1)%residual(1,neq) = elementarray(i)%residual(elementarray(i)%p+1,neq)
             elementarray(i)%massmatdiag(elementarray(i)%p+1,neq) = elementarray(i)%massmatdiag(elementarray(i)%p+1,neq) + &
                  elementarray(i+1)%massmatdiag(1,neq)
             elementarray(i+1)%massmatdiag(1,neq) = elementarray(i)%massmatdiag(elementarray(i)%p+1,neq)

          enddo

       enddo
       !     assembled matrices

       !boundary contributions
       call boundarycontribution(elementarray(1),elementarray(1)%solnvec,inpobj)
       call boundarycontribution(elementarray(inpobj%nelements),elementarray(inpobj%nelements)%solnvec,inpobj)

  end subroutine compute_explicitrhs
  !========================================================================================================
  subroutine dotimestep_explicit(elementarray,inpobj,multiplier)

    type(inputdata), intent(inout)  :: inpobj
    type(element), intent(inout) :: elementarray(:)
    real*8 :: multiplier
    integer :: i,neq,df

		  do i=1,inpobj%nelements

          		do neq=1,globalnumeq

             			do df=1,elementarray(i)%p+1

               				 elementarray(i)%solnvec(df,neq) = elementarray(i)%solnvec_prev(df,neq) +&
                     				multiplier*inpobj%timestep*elementarray(i)%residual(df,neq)/elementarray(i)%massmatdiag(df,neq)
             			enddo
          		enddo
       		enddo

  end subroutine dotimestep_explicit
  !========================================================================================================
  subroutine timestepping_Implicit(inpobj,elementarray,pointsoln,interpsoln)

    type(inputdata), intent(inout)  :: inpobj
    type(element), intent(inout) :: elementarray(:)
    real*8                       :: l2norm(globalnumeq),totaltime,printtime
    integer                      :: iterations,df,i,neq,printit
    integer                      :: numstages
    integer                      :: rkstage
    real*8                       :: multiplier
    real*8,allocatable           :: pointsoln(:,:)
    real*8,allocatable           :: interpsoln(:,:)

    real*8, allocatable           :: X(:)
    real*8, allocatable           :: X0(:)
    real*8, allocatable           :: b(:)
    real*8, allocatable           :: testvec(:)

    integer :: ndf,nelem,p,N,el

    nelem = inpobj%nelements
    p     = elementarray(1)%p

    ndf   = p*nelem + 1
    N     = ndf*globalnumeq

    allocate( X(n))
    allocate(X0(n))
    allocate( b(n))
    allocate(testvec(n))

    testvec = 1.d0

    call printsolution    (elementarray,inpobj%nelements,0,inpobj%printpointsperelement,&
		    inpobj%xscale,inpobj%scalefactors, pointsoln)

    call printpolysolution(elementarray,inpobj%nelements,0,inpobj%printpointsperelement,&
		    inpobj%xscale,inpobj%scalefactors,interpsoln)
    totaltime  = 0.d0
    printtime  = 0.d0
    printit    = 1
    iterations = 0

    do while(totaltime < inpobj%finaltime)

       totaltime  = totaltime  + inpobj%timestep
       printtime  = printtime  + inpobj%timestep
       iterations = iterations + 1

       do i=1,inpobj%nelements
       	elementarray(i)%currenttime = totaltime
       enddo

       call applydirichletbc(elementarray(inpobj%nelements),inpobj)

       do i=1,inpobj%nelements

          call computemassmatX(elementarray(i),inpobj,totaltime)
          call computediffmatX(elementarray(i),elementarray(i)%solnvec,inpobj,totaltime)

       enddo

       !boundary contributions
       call boundarycontribution(elementarray(1),elementarray(1)%solnvec,inpobj)
       call boundarycontribution(elementarray(inpobj%nelements),elementarray(inpobj%nelements)%solnvec,inpobj)

       call findBvec(b,N)

       call findX0(X0,elementarray,inpobj,n)

       call performgmres(b,X0,X,10,N,600,findAX,noprecond)

       call updatelocalsoln(X,elementarray,inpobj,n)

       write(*,'(F18.11)',advance='yes')

       if(printtime*inpobj%tscale .ge. inpobj%printtime) then

	call printsolution(elementarray,inpobj%nelements,printit,inpobj%printpointsperelement,&
			inpobj%xscale,inpobj%scalefactors,pointsoln)

    	call printpolysolution(elementarray,inpobj%nelements,printit,inpobj%printpointsperelement,&
			inpobj%xscale,inpobj%scalefactors,interpsoln)

	print *
	print *,"saving solution at time:",totaltime
	printtime=0.d0
	printit=printit+1

	endif

       print *,"totaltime:",totaltime*inpobj%tscale,"iterations:",iterations
       print *,"======================================="

    enddo

    print *,"final time:",totaltime*inpobj%tscale
    call printsolution(elementarray,inpobj%nelements,printit,inpobj%printpointsperelement,&
		    inpobj%xscale,inpobj%scalefactors,pointsoln)
    call printpolysolution(elementarray,inpobj%nelements,printit,inpobj%printpointsperelement,&
		    inpobj%xscale,inpobj%scalefactors,interpsoln)

  end subroutine timestepping_Implicit
  !========================================================================================================
  subroutine findX0(X0,elementarray,inpobj,n)

	integer, intent(in)          :: n
	real*8, intent(out)          :: X0(n)
	type(element),intent(inout)  :: elementarray(:)
	type(inputdata),intent(in)   :: inpobj

	integer :: i,nelem,p,ndf,neq,df,counter

	nelem = inpobj%nelements
	p     = elementarray(1)%p
	ndf   = p*nelem+1

	counter=0
	do neq=1,globalnumeq

		do i=1,nelem

			do df=1,p
				counter=counter+1
				X0(counter)=elementarray(i)%solnvec(df,neq)
			enddo

		enddo
		counter=counter+1
		X0(counter)=elementarray(nelem)%solnvec(p+1,neq)
	enddo

  end subroutine findX0
  !========================================================================================================
  subroutine updatelocalsoln(X,elementarray,inpobj,n)

	integer, intent(in) :: n
	real*8, intent(out) :: X(n)
	type(element),intent(inout) :: elementarray(:)
	type(inputdata),intent(in) :: inpobj

	integer :: i,nelem,p,ndf,neq,df,counter

	nelem = inpobj%nelements
	p     = elementarray(1)%p
	ndf   = p*nelem+1

	counter=0
	do neq=1,globalnumeq

		do i=1,nelem

			do df=1,p
				counter=counter+1
				elementarray(i)%solnvec(df,neq)=X(counter)
			enddo
			elementarray(i)%solnvec(p+1,neq)=X(counter+1)
		enddo
		counter=counter+1
	enddo

  end subroutine updatelocalsoln
  !========================================================================================================
  subroutine findAX(AX,X,n)

	integer, intent(in)   :: n
	real*8, intent(inout) :: X(n)
	real*8, intent(out)   :: AX(n)

	integer :: p
	real*8 :: localsolnvec(elementarray(1)%p+1,globalnumeq)
	integer :: counter,ind,i
	integer :: df,neq,ndf
	real*8  :: delt

	p = elementarray(1)%p
	delt = inpobj%timestep

	do i=1,inpobj%nelements

	  call getlocalsolnvecfromglobal(X,localsolnvec,inpobj%nelements,i,p,globalnumeq)
          call computemassmatX(elementarray(i),inpobj,elementarray(i)%currenttime)
          call computediffmatX(elementarray(i),localsolnvec,inpobj,elementarray(i)%currenttime)

        enddo

	!boundary contributions

       call getlocalsolnvecfromglobal(X,localsolnvec,inpobj%nelements,1,p,globalnumeq)
       call boundarycontribution(elementarray(1),localsolnvec,inpobj)
       call getlocalsolnvecfromglobal(X,localsolnvec,inpobj%nelements,inpobj%nelements,p,globalnumeq)
       call boundarycontribution(elementarray(inpobj%nelements),localsolnvec,inpobj)

	!fill from forward
	counter=0
        do neq=1,globalnumeq

	   do i=1,inpobj%nelements

	   	do df=1,p
	   		counter=counter+1
	   		AX(counter) = elementarray(i)%KX(df,neq)
		enddo

          enddo
	 counter=counter+1
         AX(counter) = elementarray(inpobj%nelements)%KX(p+1,neq)

       enddo

       ndf = (inpobj%nelements*p+1)

       !connection terms
       do neq=1,globalnumeq

       		do i=1,inpobj%nelements-1

			ind = (neq-1)*ndf+i*p+1
			AX(ind) = AX(ind)   + &
					elementarray(i)%KX(p+1,neq)

		enddo
	enddo

	!add mass matrix contribution
	counter=0
	do neq=1,globalnumeq

		do i=1,inpobj%nelements

			do df=1,p
				counter=counter+1
				AX(counter) = AX(counter) - elementarray(i)%massmatdiag(df,neq)*X(counter)/delt
			enddo
		enddo
		counter=counter+1
		AX(counter)=AX(counter) - elementarray(inpobj%nelements)%massmatdiag(p+1,neq)*X(counter)/delt
	enddo

	!connection mass matrix terms
        do neq=1,globalnumeq

       		do i=1,inpobj%nelements-1

			ind = (neq-1)*ndf + i*p+1
			AX(ind) = AX(ind)  - &
				elementarray(i)%massmatdiag(p+1,neq)*X(ind)/delt

		enddo
	enddo

  end subroutine findAX
  !========================================================================================================
  subroutine findBvec(b,n)

	integer, intent(in) :: n
	real*8, intent(out)  :: b(n)

	integer :: nelem,p,ind,df,i
	integer :: ndf,neq,counter
	real*8 :: delt

	nelem = inpobj%nelements
	p     = elementarray(1)%p

	ndf = nelem*p + 1
	delt = inpobj%timestep

        !without connection terms
	counter=0
	do neq=1,globalnumeq

		do i=1,nelem

			do df=1,p
				counter=counter+1
				b(counter)=elementarray(i)%F(df,neq)
			enddo
		enddo
		counter=counter+1
		b(counter) = elementarray(nelem)%F(p+1,neq)
	enddo

	!connection terms
	do neq=1,globalnumeq

		do i=1,nelem-1
			ind=(neq-1)*ndf + i*p + 1
			b(ind) = b(ind) + elementarray(i)%F(p+1,neq)
		enddo

	enddo

	!mass matrix terms
	counter=0
	do neq=1,globalnumeq

		do i=1,nelem

			do df=1,p
				counter=counter+1
				b(counter) = b(counter) + elementarray(i)%massmatdiag(df,neq)&
				*elementarray(i)%solnvec(df,neq)/delt
			enddo
		enddo
		counter=counter+1
		b(counter)=b(counter) + elementarray(inpobj%nelements)%massmatdiag(p+1,neq)&
					*elementarray(nelem)%solnvec(p+1,neq)/delt
	enddo

	!connection mass matrix terms
       do neq=1,globalnumeq

       		do i=1,nelem-1

			ind = (neq-1)*ndf + i*p+1
			b(ind) = b(ind)  + &
				elementarray(i)%massmatdiag(p+1,neq)*&
				elementarray(i)%solnvec(p+1,neq)/delt

		enddo
	enddo

	!b is -F - M/delt u^n
	b(:)=-1.d0*b(:)

  end subroutine findBvec
  !========================================================================================================
  subroutine noprecond(MinvX,X,n)

        integer, intent(in) :: n
	real*8, intent(inout) :: MinvX(n)
	real*8, intent(inout) :: X(n)

	MinvX = X

  end subroutine noprecond
  !========================================================================================================
  subroutine jacobiprecond(MinvX,X,n)

	integer, intent(in) :: n
	real*8, intent(inout) :: MinvX(n)
	real*8, intent(inout) :: X(n)

	real*8 :: diag(n)
	real*8 :: M,delt
	integer :: counter,neq,i,df
	integer :: ind,p,nelem,ndf

	diag = 0.d0
	delt = inpobj%timestep
	p     = elementarray(1)%p
	nelem = inpobj%nelements
	ndf = nelem*p + 1

	!find Diagonal term
	counter=0
	do neq=1,globalnumeq

		do i=1,nelem

			do df=1,p
				counter=counter+1
				M = elementarray(i)%massmatdiag(df,neq)
				diag(counter)=diag(counter)+elementarray(i)%diag(df,neq)-M/delt
			enddo
		enddo
		counter=counter+1
		M = elementarray(nelem)%massmatdiag(p+1,neq)
		diag(counter)=diag(counter)+elementarray(nelem)%diag(p+1,neq)-M/delt
	enddo

	!connection mass matrix terms
        do neq=1,globalnumeq

       		do i=1,nelem-1

			ind       = (neq-1)*ndf + i*p+1
			M         = elementarray(i)%massmatdiag(p+1,neq)
			diag(ind) = diag(ind) + &
				elementarray(i)%diag(p+1,neq) - M/delt

		enddo
	enddo

	MinvX = X/diag

  end subroutine jacobiprecond
  !========================================================================================================
  subroutine getlocalsolnvecfromglobal(globalvec,localvec,nelem,elnum,p,neq)

	integer, intent(in) :: p,neq,elnum,nelem
	real*8, intent(in) :: globalvec(:)
	real*8, intent(out) :: localvec(p+1,neq)

	integer :: i

	integer :: ndf,eq

	ndf = nelem*p+1

	do eq=1,neq
		localvec(:,eq)=globalvec(  (eq-1)*ndf + (elnum-1)*p + 1 : (eq-1)*ndf + &
				elnum*p + 1  )
	enddo

  end subroutine getlocalsolnvecfromglobal
  !========================================================================================================

end module timestepper_module


      SUBROUTINE SOLVDS(NN,A,NWK,MAXA,V)
C
C     This subroutine solves a system of linear equations Bx=b, where
C     B is symmetric, and is represented by its LDU factorization.
C
C     Input variables:
C
C        NN  -- dimension of B.
C
C        A -- one dimensional real array containing the upper
C             triangular skyline portion of the LDU decomposition
C             of the symmetric matrix B.
C
C        NWK  -- number of elements in A.
C
C        MAXA -- an integer array of length NN+1 which contains the
C                location in A of the diagonal elements of B.
C                By convention, MAXA(NN+1) = NWK+1 .
C
C        V -- real array of length NN containing the vector b.
C
C
C     Output variables:
C
C        V -- solution of the system of equations B x = b .
C
C
C     No working storage is required by this routine.
C
      INTEGER K,KK,KL,KU,L,NN,MAXA(NN+1),N,NWK
      DOUBLE PRECISION A(NWK),C,V(NN)
      DO 180 N=1,NN
         KL=MAXA(N)+1
         KU=MAXA(N+1)-1
         IF(KU-KL)180,160,160
160      K=N
         C=0.0
         DO 170 KK=KL,KU
            K=K-1
            C=C+A(KK)*V(K)
170      CONTINUE
         V(N)=V(N)-C
180   CONTINUE
800   DO 480 N=1,NN
         K=MAXA(N)
         V(N)=V(N)/A(K)
480   CONTINUE
      IF (NN.EQ.1) RETURN
      N=NN
      DO 500 L=2,NN
         KL=MAXA(N) + 1
         KU=MAXA(N+1) - 1
         IF (KU-KL) 530,510,510
510      K=N
         DO 520 KK=KL,KU
            K=K - 1
            V(K)=V(K) - A(KK)*V(N)
520      CONTINUE
530      N=N - 1
500   CONTINUE
      RETURN
      END


      SUBROUTINE choldc(a,n,np,p)
      INTEGER n,np
      REAL a(np,np),p(n)
      INTEGER i,j,k
      REAL sum
      do 13 i=1,n
        do 12 j=i,n
          sum=a(i,j)
          do 11 k=i-1,1,-1
            sum=sum-a(i,k)*a(j,k)
11        continue
          if(i.eq.j)then
            if(sum.le.0.)pause 'choldc failed'
            p(i)=sqrt(sum)
          else
            a(j,i)=sum/p(i)
          endif
12      continue
13    continue
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/choldc.for


SUBROUTINE qdrntflux
!-------------------------------------------------------------
!
!  Computes the volume-averaged scalar flux for the four
!   quadrants if qdflx = 1 in the input. For testing
!   purposes to compare results from Azmy test cases.
!
!-------------------------------------------------------------

USE invar
USE solvar
IMPLICIT NONE
INTEGER :: i, j, hx, hy, g
REAL*8 :: area, arflx, aveflux

! Determine the boundaries for the four quadrants
hx = nx/2
hy = ny/2
WRITE (8,'(/,1X,A)') "++++++++++++++++ Quadrant Data Requested ++++++++++++++++++++++"
! Want to loop over all groups
DO g = 1, ng
   ! Start to print the new data
   WRITE (8,'(1X,A,I2,A)') "--------------------- Group ", g, " ---------------------------"

   ! Start the loops
   ! Lower Left
   area = 0.0
   arflx = 0.0
   DO j = 1, hy
      DO i = 1, hx
         area = area + dx(i)*dy(j)
         arflx = arflx + f(i,j,0,0,g)*dx(i)*dy(j)
      END DO
   END DO
   ! Get the value for this loop
   aveflux = arflx/area
   WRITE (8,'(3X,A,ES14.6)') "Lower-Left Quadrant Average Flux = ", aveflux

   ! Lower Right
   area = 0.0
   arflx = 0.0
   DO j = 1, hy
      DO i = hx+1, nx
         area = area + dx(i)*dy(j)
         arflx = arflx + f(i,j,0,0,g)*dx(i)*dy(j)
      END DO
   END DO
   ! Get the value for this loop
   aveflux = arflx/area
   WRITE (8,'(3X,A,ES14.6)') "Lower-Right Quadrant Average Flux = ", aveflux

   ! Upper Left
   area = 0.0
   arflx = 0.0
   DO j = hy+1, ny
      DO i = 1, hx
         area = area + dx(i)*dy(j)
         arflx = arflx + f(i,j,0,0,g)*dx(i)*dy(j)
      END DO
   END DO
   ! Get the value for this loop
   aveflux = arflx/area
   WRITE (8,'(3X,A,ES14.6)') "Upper-Left Quadrant Average Flux = ", aveflux

   ! Upper Right
   area = 0.0
   arflx = 0.0
   DO j = hy+1, ny
      DO i = hx+1, nx
         area = area + dx(i)*dy(j)
         arflx = arflx + f(i,j,0,0,g)*dx(i)*dy(j)
      END DO
   END DO
   ! Get the value for this loop
   aveflux = arflx/area
   WRITE (8,'(3X,A,ES14.6,//)') "Upper-Right Quadrant Average Flux = ", aveflux
END DO

RETURN
END SUBROUTINE qdrntflux


!! MODULO CON LAS VARIABLES SCALARES GLOBALES !!

module global

    real(kind = 8) pii
    real(kind = 8) xmin, xmax, dx, courant, t, dt
    real(kind = 8) amplitude, sigma, x0
    real(kind = 8) cpu_inicio, cpu_fin
    integer resolution
    integer Nx, Nt
    integer every_scalar
    integer every_array
    integer Boundaries
    integer Metric

end module global


    program demo_reshape
    implicit none
    integer :: i
    integer, dimension(4) :: x=[(i,i=10,40,10)]
    real :: xx(3,4)
    real,allocatable :: v(:)
        ! x is originally a vector with four elements
        write(*,*) shape(x) ! what is the current shape of the array?
        write(*,*) shape(reshape(x, [2, 2]))    ! prints "2 2"

        ! pack any array into a vector
        xx=1.0
        v=reshape(xx,[size(xx)])
        write(*,*)shape(v),ubound(v)
    end program demo_reshape


      SUBROUTINE ZGET10( M, N, A, LDA, B, LDB, WORK, RWORK, RESULT )
*
*  -- LAPACK test routine (version 3.1) --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
*     November 2006
*
*     .. Scalar Arguments ..
      INTEGER            LDA, LDB, M, N
      DOUBLE PRECISION   RESULT
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   RWORK( * )
      COMPLEX*16         A( LDA, * ), B( LDB, * ), WORK( * )
*     ..
*
*  Purpose
*  =======
*
*  ZGET10 compares two matrices A and B and computes the ratio
*  RESULT = norm( A - B ) / ( norm(A) * M * EPS )
*
*  Arguments
*  =========
*
*  M       (input) INTEGER
*          The number of rows of the matrices A and B.
*
*  N       (input) INTEGER
*          The number of columns of the matrices A and B.
*
*  A       (input) COMPLEX*16 array, dimension (LDA,N)
*          The m by n matrix A.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.  LDA >= max(1,M).
*
*  B       (input) COMPLEX*16 array, dimension (LDB,N)
*          The m by n matrix B.
*
*  LDB     (input) INTEGER
*          The leading dimension of the array B.  LDB >= max(1,M).
*
*  WORK    (workspace) COMPLEX*16 array, dimension (M)
*
*  RWORK   (workspace) COMPLEX*16 array, dimension (M)
*
*  RESULT  (output) DOUBLE PRECISION
*          RESULT = norm( A - B ) / ( norm(A) * M * EPS )
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            J
      DOUBLE PRECISION   ANORM, EPS, UNFL, WNORM
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   DLAMCH, DZASUM, ZLANGE
      EXTERNAL           DLAMCH, DZASUM, ZLANGE
*     ..
*     .. External Subroutines ..
      EXTERNAL           ZAXPY, ZCOPY
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          DBLE, DCMPLX, MAX, MIN
*     ..
*     .. Executable Statements ..
*
*     Quick return if possible
*
      IF( M.LE.0 .OR. N.LE.0 ) THEN
         RESULT = ZERO
         RETURN
      END IF
*
      UNFL = DLAMCH( 'Safe minimum' )
      EPS = DLAMCH( 'Precision' )
*
      WNORM = ZERO
      DO 10 J = 1, N
         CALL ZCOPY( M, A( 1, J ), 1, WORK, 1 )
         CALL ZAXPY( M, DCMPLX( -ONE ), B( 1, J ), 1, WORK, 1 )
         WNORM = MAX( WNORM, DZASUM( N, WORK, 1 ) )
   10 CONTINUE
*
      ANORM = MAX( ZLANGE( '1', M, N, A, LDA, RWORK ), UNFL )
*
      IF( ANORM.GT.WNORM ) THEN
         RESULT = ( WNORM / ANORM ) / ( M*EPS )
      ELSE
         IF( ANORM.LT.ONE ) THEN
            RESULT = ( MIN( WNORM, M*ANORM ) / ANORM ) / ( M*EPS )
         ELSE
            RESULT = MIN( WNORM / ANORM, DBLE( M ) ) / ( M*EPS )
         END IF
      END IF
*
      RETURN
*
*     End of ZGET10
*
      END


! examples/Fortran/scaling/equilib_sym.f90 - Example code for SPRAL_SCALING
program equilib_scale_sym_example
   use spral_scaling
   use spral_matrix_util, only : print_matrix, &
                                 SPRAL_MATRIX_REAL_SYM_INDEF
   implicit none

   ! Derived types
   type (equilib_options)  :: options
   type (equilib_inform)   :: inform

   ! Parameters
   integer, parameter :: wp = kind(0.0d0)

   ! Matrix data
   integer :: n, ptr(6), row(8)
   real(wp) :: val(8)

   ! Other variables
   integer :: i, j
   real(wp) :: scaling(5)

   ! Data for symmetric matrix:
   ! ( 2  1         )
   ! ( 1  4  1    8 )
   ! (    1  3  2   )
   ! (       2      )
   ! (    8       2 )
   n = 5
   ptr(1:n+1)        = (/ 1,        3,             6,      8,8,   9 /)
   row(1:ptr(n+1)-1) = (/ 1,   2,   2,   3,   5,   3,   4,   5   /)
   val(1:ptr(n+1)-1) = (/ 2.0, 1.0, 4.0, 1.0, 8.0, 3.0, 2.0, 2.0 /)
   write(*, "(a)") "Initial matrix:"
   call print_matrix(6, -1, SPRAL_MATRIX_REAL_SYM_INDEF, n, n, ptr, row, val)

   ! Perform symmetric scaling
   call equilib_scale_sym(n, ptr, row, val, scaling, options, inform)
   if(inform%flag<0) then
      write(*, "(a, i5)") "equilib_scale_sym() returned with error ", &
         inform%flag
      stop
   endif

   ! Print scaling and matching
   write(*,"(a,10es10.2)") 'Scaling: ', scaling(1:n)

   ! Calculate scaled matrix and print it
   do i = 1, n
      do j = ptr(i), ptr(i+1)-1
         val(j) = scaling(i) * val(j) * scaling(row(j))
      end do
   end do
   write(*, "(a)") "Scaled matrix:"
   call print_matrix(6, -1, SPRAL_MATRIX_REAL_SYM_INDEF, n, n, ptr, row, val)

end program equilib_scale_sym_example


!---Solve velocity field
!
!---Input: n - element number
!
!---Output:
!

subroutine solve_temperature_ss(n,nl_iter)

    USE flags_M
    USE material_info_M
    USE mesh_info_M
    USE time_info_M
    USE global_parameters_M
    USE solution_vectors_M
    USE element_matrices_M
    use Mod_SetupOutputFiles

implicit none

!---Dummy
    integer, intent(in) :: n
    integer, intent(in) :: nl_iter

!---Local
    integer :: i, j, length
    real(dp) :: temperature_eval
    real(dp), dimension(3)   :: rhs_final_vec,elem_vec_w_left,&
                                elem_vec_q_temp
    real(dp), dimension(3,3) :: inverse_matrix
    real(dp) :: volume, heat_capacity_eval, density_eval
!---Inversion routine parameters
    integer :: lda, info, lwork
    integer,  dimension(3) :: ipiv
    real(dp), dimension(3) :: work
    real(dp) :: salt_mass, q_prime, length_core

!---size of matrix 3x3
    length = 3
!---Initialize inversion routine
    ipiv   = 0
    work   = 0.0
    lda    = length
    lwork  = length

!---Temperature SOLVE
    rhs_final_vec        = 0.0_dp
    elem_vec_q_temp      = 0.0_dp
    elem_vec_w_left      = 0.0_dp

!---Setup RHS matrix to be inverted later on
    do i = 1, nodes_per_elem
        do j = 1, nodes_per_elem
            inverse_matrix(i,j) = -1.0*elem_matrix_U(i,j) + matrix_W_right_face(i,j)
        end do
    end do

    !write(outfile_unit,fmt='(a)'), ' '
    !   write(outfile_unit,fmt='(a,I6)'),'[W_r - U] Matrix | element --> ',n
    !   do j=1,nodes_per_elem
    !         write(outfile_unit,fmt='(12es14.3)') &
    !              ( inverse_matrix(j,i),i=1,nodes_per_elem)
    !   end do

!---Factorize RHS matrix matrix
    call dgetrf ( length, length, inverse_matrix, lda, ipiv, info )
!---Compute the inverse matrix.
    call dgetri ( length, inverse_matrix, lda, ipiv, work, lwork, info )

    volume = 0.0_dp
!---Calculate core volume
    do i = Fuel_Inlet_start, Fuel_Outlet_End
        do j = 1, nodes_per_elem
            volume = volume + vol_int(j)*area_variation(i,j)
        end do
    end do

    temperature_eval = 0.0
    !---Get temperature over element
    do j = 1, nodes_per_elem
        !---valuate density based on temperature
        temperature_eval = temperature_eval + vol_int(j)*temperature_soln_new(n,j)
    end do

    call density_corr(temperature_eval, density_eval)

!---Loop over all nodes in element
    do j = 1, nodes_per_elem

       call heat_capacity_corr(temperature_eval, heat_capacity_eval)
       length_core = Fuel_Outlet_End - Fuel_Inlet_start

       q_prime = (total_power_initial*power_amplitude_prev*&
                  spatial_power_frac_fcn(n,j))/spatial_area_fcn(n,j)

       elem_vec_q_temp(j) = elem_vec_q(j)*q_prime*(1.0_dp/(density_eval*heat_capacity_eval))
    end do
!----Evaluate W*T_e-1
    do i = 1, nodes_per_elem
        do j = 1, nodes_per_elem

            if(n > 1) then
                elem_vec_w_left(j) = elem_vec_w_left(j) + &
                                     matrix_W_left_face(i,j)*&
                                     temperature_soln_new(n-1,3)
            else
                elem_vec_w_left(j) = elem_vec_w_left(j) + &
                                     matrix_W_left_face(i,j)*&
                                     temperature_soln_new(n,3)
            end if

        end do
    end do

    do i = 1, nodes_per_elem
        rhs_final_vec(i) = elem_vec_q_temp(i) + elem_vec_w_left(i)
    end do

!---Final calculation
    temperature_soln_new(n,:) = matmul(inverse_matrix, rhs_final_vec)

    if( n == Fuel_Inlet_start) then
        do i = 1, nodes_per_elem
            temperature_soln_new(n,i) = 850.0_dp
        end do
    end if

    if( n == Heat_Exchanger_End) then
        do i = 1, nodes_per_elem
            temperature_soln_new(n,i) = 850.0_dp
        end do
    end if

    temperature_reduction = 100.0_dp
    do j = 1, nodes_per_elem
        !---Start heat exchanger
        if ( Heat_Exchanger_Start <= n  .and.  n < Heat_Exchanger_End) then
            temperature_soln_new(n,j) = (temperature_reduction)/&
            (Heat_Exchanger_End - Heat_Exchanger_Start)* &
            (global_coord(Heat_Exchanger_End-1,3)  - global_coord(n,j) ) - temperature_reduction + &
            temperature_soln_new(Heat_Exchanger_Start-1,1)
        end if
    end do

!---Fix delta T across heat exchanger
    !do j = 1, nodes_per_elem
    !    !---Start heat exchanger
    !    if ( Heat_Exchanger_Start <= n  .and.  n < Heat_Exchanger_End) then
    !        temperature_soln_new(n,j) = (100.0_dp)/&
    !        (Heat_Exchanger_End - Heat_Exchanger_Start)* &
    !        (global_coord(Heat_Exchanger_End-1,3)  - global_coord(n,3) ) - 100.0_dp + &
    !        temperature_soln_new(Heat_Exchanger_Start-1,1)
    !    end if
    !end do

if( n > Heat_Exchanger_End) then
        do j = 1, nodes_per_elem
            temperature_soln_new(n,j) = temperature_soln_new(Heat_Exchanger_End,j)
        end do
    end if

!DEBUG = .TRUE.
if( DEBUG .eqv. .TRUE.) then

       write(outfile_unit,fmt='(a,4I6)'), 'nl iter ',nl_iter

       if( n > 1) then
            write(outfile_unit,fmt='(a,4I6)'),' T_e-1 vector  --> ',n
            write(outfile_unit,fmt='(12es14.3)') &
                  (temperature_soln_new(n-1,i),i=1,nodes_per_elem)
       else
            write(outfile_unit,fmt='(a,4I6)'),' T_e-1 vector  --> ',n
            write(outfile_unit,fmt='(12es14.3)') &
                  (temperature_soln_new(n,i),i=1,nodes_per_elem)
        end if

       write(outfile_unit,fmt='(a)'), ' '
       write(outfile_unit,fmt='(a,4I6)'),' T_e vector  --> ',n
       write(outfile_unit,fmt='(12es14.3)') &
                  (temperature_soln_new(n,i),i=1,nodes_per_elem)

              write(outfile_unit,fmt='(a)'), ' '
       write(outfile_unit,fmt='(a,I6)'),'[W_r - U]^-1 Matrix | element --> ',n
       do j=1,nodes_per_elem
             write(outfile_unit,fmt='(12es14.3)') &
                  (inverse_matrix(j,i),i=1,nodes_per_elem)
       end do

       write(outfile_unit,fmt='(a)'), ' '
       write(outfile_unit,fmt='(a,4I6)'),' [W_L]*{T_e-1} | element --> ',n
       do j=1,nodes_per_elem
             write(outfile_unit,fmt='(12es14.3)') &
                    elem_vec_w_left(j)
       end do
       write(outfile_unit,fmt='(a,4I6)'),' 1/Cp*rho*vol * {q} vector  --> ',n
             write(outfile_unit,fmt='(12es14.3)') &
                  (elem_vec_q_temp(i),i=1,nodes_per_elem)

       write(outfile_unit,fmt='(a,4I6)'),'RHS vector  vector  --> ',n
             write(outfile_unit,fmt='(12es14.3)') &
                 (rhs_final_vec(i),i=1,nodes_per_elem)

       write(outfile_unit,fmt='(a)'),'*****************************************'
    end if

DEBUG = .FALSE.

end subroutine solve_temperature_ss


  !!-------------------------------------------------------
  !!
  !!               [obsolete] Generic intertface
  !!
  !!-------------------------------------------------------
  FUNCTION specModel_gen( wvl, parvec, parname, parinfo, indpar, parval, Qabs, extinct, &
                          verbose, debug )

    USE utilities, ONLY: DP, trimeq, trimlr, pring, &!verbatim, &
                         initiate_clock, time_type, timinfo!, ustd
    USE constants, ONLY: pi, MKS
    USE arrays, ONLY: reallocate
    USE statistical_physics, ONLY: blackbody
    IMPLICIT NONE

    REAL(DP), DIMENSION(:), INTENT(IN)           :: wvl, extinct
    REAL(DP), DIMENSION(:), INTENT(IN)           :: parvec, parval
    CHARACTER(*), INTENT(IN)                     :: parname
    TYPE(parinfo_type), DIMENSION(:), INTENT(IN) :: parinfo
    TYPE(indpar_type), INTENT(IN)                :: indpar
    TYPE(Qabs_type), DIMENSION(:), INTENT(IN)    :: Qabs
    LOGICAL, INTENT(IN), OPTIONAL                :: verbose, debug

    INTEGER :: Nw, Ngrid, Ncont, Nline, Nband, Npabs, Nstar
    INTEGER :: i, igrid, iw, j!, itied
    REAL(DP)                                     :: Tstar
    REAL(DP), DIMENSION(SIZE(wvl))               :: nu
    LOGICAL :: gridlnMovd2, gridlnT, gridlnIline, gridCline, gridWline
    LOGICAL :: gridlnIband, gridCband, gridWSband, gridWLband, gridlnAv, gridlnFstar
    REAL(DP), DIMENSION(SIZE(parvec),SIZE(wvl)) :: FnuCONT0, FnuBAND0, FnuSTAR0
    REAL(DP), DIMENSION(SIZE(parvec),SIZE(wvl)) :: Pabs0, FnuLINE0
    REAL(DP) :: Const
    REAL(DP), DIMENSION(SIZE(wvl)) :: Const1D
    REAL(DP), DIMENSION(SIZE(parvec),SIZE(wvl)) :: specModel_gen

    LOGICAL :: printimer, bls
    TYPE(time_type) :: timestr

    CALL INITIATE_CLOCK(timestr)

    !! Preliminaries
    !!---------------
    Nw = SIZE(wvl(:))
    Ngrid = SIZE(parvec(:))
    ! Ncont = SIZE(Qabs(:))
    Ncont = SIZE( PACK(parinfo(:), TRIMEQ(parinfo(:)%comp, 'CONT')) ) / NparCONT
    Nline = SIZE( PACK(parinfo(:), TRIMEQ(parinfo(:)%comp, 'LINE')) ) / NparLINE
    Nband = SIZE( PACK(parinfo(:), TRIMEQ(parinfo(:)%comp, 'BAND')) ) / NparBAND
    Npabs = SIZE( PACK(parinfo(:), TRIMEQ(parinfo(:)%comp, 'PABS')) ) / NparPABS
    Nstar = SIZE( PACK(parinfo(:), TRIMEQ(parinfo(:)%comp, 'STAR')) ) / NparSTAR
    Tstar = 5.E4_DP ! [K] high enough to stay in Rayleigh-Jeans limit (T>>5000K for 3um)
    nu(:) = MKS%clight / wvl(:) /MKS%micron

    !! Verbose
    printimer = .FALSE. ! Print timer
    IF (PRESENT(verbose)) printimer = verbose

    !! Debug
    bls = .FALSE.
    IF (PRESENT(debug)) bls = debug

    !! Is the parameter tied to another one?
    ! tied = ANY(TRIMEQ(parinfo(:)%tied, parname))
    ! IF (tied) CALL IWHERE( TRIMEQ(parinfo(:)%tied, parname), itied )

    !! Initialization
    specModel_gen(:,:) = 0._DP

    !! 1. Continuum
    !!--------------
    loopCONT: DO i=1,Ncont
      gridlnMovd2 = TRIMEQ(parname, 'lnMovd2'//TRIMLR(PRING(i)))
      gridlnT = TRIMEQ(parname, 'lnT'//TRIMLR(PRING(i)))

      IF (gridlnMovd2) THEN
        !! CONT *lnMovd2
        Const1D(:) = MKS%Msun/MKS%pc**2 * modifBB(wvl(:), EXP(parval(indpar%lnT(i))), Qabs(i))
        FORALL (igrid=1:Ngrid) &
          FnuCONT0(igrid,:) = EXP(parvec(igrid)) * Const1D(:)
        !! CONT
        Const1D(:) = 0._DP
        DO j=1,Ncont
          IF (j.NE.i) &
            Const1D(:) = Const1D(:) + EXP(parval(indpar%lnMovd2(j))) * MKS%Msun/MKS%pc**2 * &
                         modifBB(wvl(:), EXP(parval(indpar%lnT(j))), Qabs(j))

        END DO
        FORALL (iw=1:Nw) FnuCONT0(:,iw) = FnuCONT0(:,iw) + Const1D(iw)
        !! BAND
        Const1D(:) = 0._DP
        DO j=1,Nband
          Const1D(:) = Const1D(:) + EXP(parval(indpar%lnIband(j))) * &
                       lorentzBand(wvl(:), parval(indpar%Cband(j)), &
                         parval(indpar%WSband(j)), parval(indpar%WLband(j)))

        END DO
        FORALL (iw=1:Nw) FnuBAND0(:,iw) = Const1D(iw)
        !! STAR
        Const1D(:) = 0._DP
        DO j=1,Nstar
          Const1D(:) = Const1D(:) + EXP(parval(indpar%lnFstar(j))) * &
                       pi * BLACKBODY(nu(:), Tstar) /MKS%stefan/Tstar**4

        END DO
        FORALL (iw=1:Nw) FnuSTAR0(:,iw) = Const1D(iw)
        !! LINE
        Const1D(:) = 0._DP
        DO j=1,Nline
          Const1D(:) = Const1D(:) + EXP(parval(indpar%lnIline(j))) * &
                       gaussLine(wvl(:), parval(indpar%Cline(j)), &
                         parval(indpar%Wline(j)))

        END DO
        FORALL (iw=1:Nw) FnuLINE0(:,iw) = Const1D(iw)
        !! PABS (May need to modify if consider different geometries)
        Const1D(:) = 0._DP
        DO j=1,Npabs
          Const1D(:) = Const1D(:) + EXP(parval(indpar%lnAv(j)))

        END DO
        FORALL (iw=1:Nw) Pabs0(:,iw) = EXP( -Const1D(iw)/1.086_DP * extinct(iw) )
        !! Total model
        specModel_gen(:,:) = (FnuCONT0(:,:) + FnuBAND0(:,:) + FnuSTAR0(:,:)) * &
                             Pabs0(:,:) + FnuLINE0(:,:)

      ELSE IF (gridlnT) THEN
        !! CONT *lnT
        Const = EXP(parval(indpar%lnMovd2(i))) * MKS%Msun/MKS%pc**2
        FORALL (igrid=1:Ngrid) &
          FnuCONT0(igrid,:) = Const * modifBB(wvl(:), EXP(parvec(igrid)), Qabs(i))
        !! CONT
        Const1D(:) = 0._DP
        DO j=1,Ncont
          IF (j.NE.i) &
            Const1D(:) = Const1D(:) + EXP(parval(indpar%lnMovd2(j))) * MKS%Msun/MKS%pc**2 * &
                         modifBB(wvl(:), EXP(parval(indpar%lnT(j))), Qabs(j))

        END DO
        FORALL (iw=1:Nw) FnuCONT0(:,iw) = FnuCONT0(:,iw) + Const1D(iw)
        !! BAND
        Const1D(:) = 0._DP
        DO j=1,Nband
          Const1D(:) = Const1D(:) + EXP(parval(indpar%lnIband(j))) * &
                       lorentzBand(wvl(:), parval(indpar%Cband(j)), &
                         parval(indpar%WSband(j)), parval(indpar%WLband(j)))

        END DO
        FORALL (iw=1:Nw) FnuBAND0(:,iw) = Const1D(iw)
        !! STAR
        Const1D(:) = 0._DP
        DO j=1,Nstar
          Const1D(:) = Const1D(:) + EXP(parval(indpar%lnFstar(j))) * &
                       pi * BLACKBODY(nu(:), Tstar) /MKS%stefan/Tstar**4

        END DO
        FORALL (iw=1:Nw) FnuSTAR0(:,iw) = Const1D(iw)
        !! LINE
        Const1D(:) = 0._DP
        DO j=1,Nline
          Const1D(:) = Const1D(:) + EXP(parval(indpar%lnIline(j))) * &
                       gaussLine(wvl(:), parval(indpar%Cline(j)), &
                         parval(indpar%Wline(j)))

        END DO
        FORALL (iw=1:Nw) FnuLINE0(:,iw) = Const1D(iw)
        !! PABS
        Const1D(:) = 0._DP
        DO j=1,Npabs
          Const1D(:) = Const1D(:) + EXP(parval(indpar%lnAv(j)))

        END DO
        FORALL (iw=1:Nw) Pabs0(:,iw) = EXP( -Const1D(iw)/1.086_DP * extinct(iw) )
        !! Total model
        specModel_gen(:,:) = (FnuCONT0(:,:) + FnuBAND0(:,:) + FnuSTAR0(:,:)) * &
                             Pabs0(:,:) + FnuLINE0(:,:)

      END IF

      !! BLS (Bug Localization System)
      IF (bls) THEN
        IF (ANY(isNaN(specModel_gen))) THEN
          IF (gridlnMovd2) THEN
            PRINT*, "lnMovd2"//TRIMLR(PRING(i))
          ELSE IF (gridlnT) THEN
            PRINT*, "lnT"//TRIMLR(PRING(i))
          END IF

          IF (ANY(isNaN(FnuCONT0))) THEN
            PRINT*, 'FnuCONT0'
          END IF
          IF (ANY(isNaN(FnuBAND0))) THEN
            PRINT*, 'FnuBAND0'
          END IF
          IF (ANY(isNaN(FnuSTAR0))) THEN
            PRINT*, 'FnuSTAR0'
          END IF
          IF (ANY(isNaN(PABS0))) THEN
            PRINT*, 'PABS0'
          END IF
          IF (ANY(isNaN(FnuLINE0))) THEN
            PRINT*, 'FnuLINE0'
          END IF
          STOP
        END IF
      END IF

    END DO loopCONT

    IF (printimer) &
      PRINT*, "[specModel] CAL CONT IN "//TRIMLR(TIMINFO(timestr))//"."

    !! 2. Bands
    !!----------
    loopBAND: DO i=1,Nband
      gridlnIband = TRIMEQ(parname, 'lnIband'//TRIMLR(PRING(i)))
      gridCband = TRIMEQ(parname, 'Cband'//TRIMLR(PRING(i)))
      gridWSband = TRIMEQ(parname, 'WSband'//TRIMLR(PRING(i)))
      gridWLband = TRIMEQ(parname, 'WLband'//TRIMLR(PRING(i)))

      IF (gridlnIband) THEN
        !! CONT
        Const1D(:) = 0._DP
        DO j=1,Ncont
          Const1D(:) = Const1D(:) + EXP(parval(indpar%lnMovd2(j))) * MKS%Msun/MKS%pc**2 * &
                       modifBB(wvl(:), EXP(parval(indpar%lnT(j))), Qabs(j))

        END DO
        FORALL (iw=1:Nw) FnuCONT0(:,iw) = Const1D(iw)
        !! BAND *lnIband
        Const1D(:) = lorentzBand(wvl(:), parval(indpar%Cband(i)), &
                       parval(indpar%WSband(i)), parval(indpar%WLband(i)))
        FORALL (igrid=1:Ngrid) &
          FnuBAND0(igrid,:) = EXP(parvec(igrid)) * Const1D(:)
! if (any(isnan(Const1D))) print*, "*lnIband", &
  ! new_line('a'), parval(indpar%cband(i)), parval(indpar%wsband(i)), parval(indpar%wlband(i))

        !! BAND
        Const1D(:) = 0._DP
        DO j=1,Nband
          IF (j.NE.i) &
            Const1D(:) = Const1D(:) + EXP(parval(indpar%lnIband(j))) * &
                         lorentzBand(wvl(:), parval(indpar%Cband(j)), &
                           parval(indpar%WSband(j)), parval(indpar%WLband(j)))
! if (j.NE.i .AND. any(isnan(lorentzBand(wvl(:), parval(indpar%Cband(j)), &
!   parval(indpar%WSband(j)), parval(indpar%WLband(j)))))) &
!   print*, "lnIband", j, new_line('a'), &
!   new_line('a'), parval(indpar%cband(j)), parval(indpar%wsband(j)), parval(indpar%wlband(j))

        END DO
        FORALL (iw=1:Nw) FnuBAND0(:,iw) = FnuBAND0(:,iw) + Const1D(iw)
        !! STAR
        Const1D(:) = 0._DP
        DO j=1,Nstar
          Const1D(:) = Const1D(:) + EXP(parval(indpar%lnFstar(j))) * &
                       pi * BLACKBODY(nu(:), Tstar) /MKS%stefan/Tstar**4

        END DO
        FORALL (iw=1:Nw) FnuSTAR0(:,iw) = Const1D(iw)
        !! LINE
        Const1D(:) = 0._DP
        DO j=1,Nline
          Const1D(:) = Const1D(:) + EXP(parval(indpar%lnIline(j))) * &
                       gaussLine(wvl(:), parval(indpar%Cline(j)), &
                         parval(indpar%Wline(j)))

        END DO
        FORALL (iw=1:Nw) FnuLINE0(:,iw) = Const1D(iw)
        !! PABS
        Const1D(:) = 0._DP
        DO j=1,Npabs
          Const1D(:) = Const1D(:) + EXP(parval(indpar%lnAv(j)))

        END DO
        FORALL (iw=1:Nw) Pabs0(:,iw) = EXP( -Const1D(iw)/1.086_DP * extinct(iw) )
        !! Total model
        specModel_gen(:,:) = (FnuCONT0(:,:) + FnuBAND0(:,:) + FnuSTAR0(:,:)) * &
                             Pabs0(:,:) + FnuLINE0(:,:)

      ELSE IF (gridCband) THEN
        !! CONT
        Const1D(:) = 0._DP
        DO j=1,Ncont
          Const1D(:) = Const1D(:) + EXP(parval(indpar%lnMovd2(j))) * MKS%Msun/MKS%pc**2 * &
                       modifBB(wvl(:), EXP(parval(indpar%lnT(j))), Qabs(j))

        END DO
        FORALL (iw=1:Nw) FnuCONT0(:,iw) = Const1D(iw)
        !! BAND *Cband
        Const = EXP(parval(indpar%lnIband(i)))
        FORALL (igrid=1:Ngrid) &
          FnuBAND0(igrid,:) = Const * lorentzBand(wvl(:), parvec(igrid), &
                                        parval(indpar%WSband(i)), parval(indpar%WLband(i)))
! if (any(isnan(fnuband0))) print*, "*Cband"//trimlr(pring(i)), &
  ! new_line('a'), parval(indpar%cband(i)), parval(indpar%wsband(i)), parval(indpar%wlband(i))

        !! BAND
        Const1D(:) = 0._DP
        DO j=1,Nband
          IF (j.NE.i) &
            Const1D(:) = Const1D(:) + EXP(parval(indpar%lnIband(j))) * &
                         lorentzBand(wvl(:), parval(indpar%Cband(j)), &
                           parval(indpar%WSband(j)), parval(indpar%WLband(j)))
! if (j.NE.i .AND. any(isnan(lorentzBand(wvl(:), parval(indpar%Cband(j)), &
!   parval(indpar%WSband(j)), parval(indpar%WLband(j)))))) &
!   print*, "Cband", j, new_line('a'), &
!   new_line('a'), parval(indpar%cband(j)), parval(indpar%wsband(j)), parval(indpar%wlband(j))

        END DO
        FORALL (iw=1:Nw) FnuBAND0(:,iw) = FnuBAND0(:,iw) + Const1D(iw)
        !! STAR
        Const1D(:) = 0._DP
        DO j=1,Nstar
          Const1D(:) = Const1D(:) + EXP(parval(indpar%lnFstar(j))) * &
                       pi * BLACKBODY(nu(:), Tstar) /MKS%stefan/Tstar**4

        END DO
        FORALL (iw=1:Nw) FnuSTAR0(:,iw) = Const1D(iw)
        !! LINE
        Const1D(:) = 0._DP
        DO j=1,Nline
          Const1D(:) = Const1D(:) + EXP(parval(indpar%lnIline(j))) * &
                       gaussLine(wvl(:), parval(indpar%Cline(j)), &
                         parval(indpar%Wline(j)))

        END DO
        FORALL (iw=1:Nw) FnuLINE0(:,iw) = Const1D(iw)
        !! PABS
        Const1D(:) = 0._DP
        DO j=1,Npabs
          Const1D(:) = Const1D(:) + EXP(parval(indpar%lnAv(j)))

        END DO
        FORALL (iw=1:Nw) Pabs0(:,iw) = EXP( -Const1D(iw)/1.086_DP * extinct(iw) )
        !! Total model
        specModel_gen(:,:) = (FnuCONT0(:,:) + FnuBAND0(:,:) + FnuSTAR0(:,:)) * &
                             Pabs0(:,:) + FnuLINE0(:,:)

      ELSE IF (gridWSband) THEN
        !! CONT
        Const1D(:) = 0._DP
        DO j=1,Ncont
          Const1D(:) = Const1D(:) + EXP(parval(indpar%lnMovd2(j))) * MKS%Msun/MKS%pc**2 * &
                       modifBB(wvl(:), EXP(parval(indpar%lnT(j))), Qabs(j))

        END DO
        FORALL (iw=1:Nw) FnuCONT0(:,iw) = Const1D(iw)
        !! BAND *WSband
        Const = EXP(parval(indpar%lnIband(i)))
        FORALL (igrid=1:Ngrid) &
          FnuBAND0(igrid,:) = Const * lorentzBand(wvl(:), parval(indpar%Cband(i)), &
                                        parvec(igrid), parval(indpar%WLband(i)))
! if (any(isnan(fnuband0))) print*, "*WSband", &
!   new_line('a'), parval(indpar%cband(i)), parval(indpar%wsband(i)), parval(indpar%wlband(i))

        !! BAND
        Const1D(:) = 0._DP
        DO j=1,Nband
          IF (j.NE.i) &
            Const1D(:) = Const1D(:) + EXP(parval(indpar%lnIband(j))) * &
                         lorentzBand(wvl(:), parval(indpar%Cband(j)), &
                           parval(indpar%WSband(j)), parval(indpar%WLband(j)))
! if (j.NE.i .AND. any(isnan(lorentzBand(wvl(:), parval(indpar%Cband(j)), &
!   parval(indpar%WSband(j)), parval(indpar%WLband(j)))))) &
!   print*, "WSband", j, new_line('a'), &
!   new_line('a'), parval(indpar%cband(j)), parval(indpar%wsband(j)), parval(indpar%wlband(j))

        END DO
        FORALL (iw=1:Nw) FnuBAND0(:,iw) = FnuBAND0(:,iw) + Const1D(iw)
        !! STAR
        Const1D(:) = 0._DP
        DO j=1,Nstar
          Const1D(:) = Const1D(:) + EXP(parval(indpar%lnFstar(j))) * &
                       pi * BLACKBODY(nu(:), Tstar) /MKS%stefan/Tstar**4

        END DO
        FORALL (iw=1:Nw) FnuSTAR0(:,iw) = Const1D(iw)
        !! LINE
        Const1D(:) = 0._DP
        DO j=1,Nline
          Const1D(:) = Const1D(:) + EXP(parval(indpar%lnIline(j))) * &
                       gaussLine(wvl(:), parval(indpar%Cline(j)), &
                         parval(indpar%Wline(j)))

        END DO
        FORALL (iw=1:Nw) FnuLINE0(:,iw) = Const1D(iw)
        !! PABS
        Const1D(:) = 0._DP
        DO j=1,Npabs
          Const1D(:) = Const1D(:) + EXP(parval(indpar%lnAv(j)))

        END DO
        FORALL (iw=1:Nw) Pabs0(:,iw) = EXP( -Const1D(iw)/1.086_DP * extinct(iw) )
        !! Total model
        specModel_gen(:,:) = (FnuCONT0(:,:) + FnuBAND0(:,:) + FnuSTAR0(:,:)) * &
                             Pabs0(:,:) + FnuLINE0(:,:)

      ELSE IF (gridWLband) THEN
        !! CONT
        Const1D(:) = 0._DP
        DO j=1,Ncont
          Const1D(:) = Const1D(:) + EXP(parval(indpar%lnMovd2(j))) * MKS%Msun/MKS%pc**2 * &
                       modifBB(wvl(:), EXP(parval(indpar%lnT(j))), Qabs(j))

        END DO
        FORALL (iw=1:Nw) FnuCONT0(:,iw) = Const1D(iw)
        !! BAND *WLband
        Const = EXP(parval(indpar%lnIband(i)))
        FORALL (igrid=1:Ngrid) &
          FnuBAND0(igrid,:) = Const * lorentzBand(wvl(:), parval(indpar%Cband(i)), &
                                        parval(indpar%WSband(i)), parvec(igrid))
! if (any(isnan(fnuband0))) print*, "*WLband", &
!   new_line('a'), parval(indpar%cband(i)), parval(indpar%wsband(i)), parval(indpar%wlband(i))

        !! BAND
        Const1D(:) = 0._DP
        DO j=1,Nband
          IF (j.NE.i) &
            Const1D(:) = Const1D(:) + EXP(parval(indpar%lnIband(j))) * &
                         lorentzBand(wvl(:), parval(indpar%Cband(j)), &
                           parval(indpar%WSband(j)), parval(indpar%WLband(j)))
! if (j.NE.i .AND. any(isnan(lorentzBand(wvl(:), parval(indpar%Cband(j)), &
!   parval(indpar%WSband(j)), parval(indpar%WLband(j)))))) &
!   print*, "WLband", j, new_line('a'), &
!   new_line('a'), parval(indpar%cband(j)), parval(indpar%wsband(j)), parval(indpar%wlband(j))

        END DO
        FORALL (iw=1:Nw) FnuBAND0(:,iw) = FnuBAND0(:,iw) + Const1D(iw)
        !! STAR
        Const1D(:) = 0._DP
        DO j=1,Nstar
          Const1D(:) = Const1D(:) + EXP(parval(indpar%lnFstar(j))) * &
                       pi * BLACKBODY(nu(:), Tstar) /MKS%stefan/Tstar**4

        END DO
        FORALL (iw=1:Nw) FnuSTAR0(:,iw) = Const1D(iw)
        !! LINE
        Const1D(:) = 0._DP
        DO j=1,Nline
          Const1D(:) = Const1D(:) + EXP(parval(indpar%lnIline(j))) * &
                       gaussLine(wvl(:), parval(indpar%Cline(j)), &
                         parval(indpar%Wline(j)))

        END DO
        FORALL (iw=1:Nw) FnuLINE0(:,iw) = Const1D(iw)
        !! PABS
        Const1D(:) = 0._DP
        DO j=1,Npabs
          Const1D(:) = Const1D(:) + EXP(parval(indpar%lnAv(j)))

        END DO
        FORALL (iw=1:Nw) Pabs0(:,iw) = EXP( -Const1D(iw)/1.086_DP * extinct(iw) )
        !! Total model
        specModel_gen(:,:) = (FnuCONT0(:,:) + FnuBAND0(:,:) + FnuSTAR0(:,:)) * &
                             Pabs0(:,:) + FnuLINE0(:,:)

      END IF

      !! BLS (Bug Localization System)
      IF (bls) THEN
        IF (ANY(isNaN(specModel_gen))) THEN
          IF (gridlnIband) THEN
            PRINT*, "lnIband"//TRIMLR(PRING(i))
          ELSE IF (gridCband) THEN
            PRINT*, "Cband"//TRIMLR(PRING(i))
          ELSE IF (gridWSband) THEN
            PRINT*, "WSband"//TRIMLR(PRING(i))
          ELSE IF (gridWLband) THEN
            PRINT*, "WLband"//TRIMLR(PRING(i))
          END IF

          IF (ANY(isNaN(FnuCONT0))) THEN
            PRINT*, 'FnuCONT0'
          END IF
          IF (ANY(isNaN(FnuBAND0))) THEN
            PRINT*, 'FnuBAND0'
          END IF
          IF (ANY(isNaN(FnuSTAR0))) THEN
            PRINT*, 'FnuSTAR0'
          END IF
          IF (ANY(isNaN(PABS0))) THEN
            PRINT*, 'PABS0'
          END IF
          IF (ANY(isNaN(FnuLINE0))) THEN
            PRINT*, 'FnuLINE0'
          END IF
          STOP
        END IF
      END IF

    END DO loopBAND

    IF (printimer) &
      PRINT*, "[specModel] CAL BAND IN "//TRIMLR(TIMINFO(timestr))//"."

    !! 3. Stellar Continuum
    !!----------------------
    loopSTAR: DO i=1,Nstar
      gridlnFstar = TRIMEQ(parname, 'lnFstar'//TRIMLR(PRING(i)))

      IF (gridlnFstar) THEN
        !! CONT
        Const1D(:) = 0._DP
        DO j=1,Ncont
          Const1D(:) = Const1D(:) + EXP(parval(indpar%lnMovd2(j))) * MKS%Msun/MKS%pc**2 * &
                       modifBB(wvl(:), EXP(parval(indpar%lnT(j))), Qabs(j))

        END DO
        FORALL (iw=1:Nw) FnuCONT0(:,iw) = Const1D(iw)
        !! BAND
        Const1D(:) = 0._DP
        DO j=1,Nband
          Const1D(:) = Const1D(:) + EXP(parval(indpar%lnIband(j))) * &
                       lorentzBand(wvl(:), parval(indpar%Cband(j)), &
                         parval(indpar%WSband(j)), parval(indpar%WLband(j)))

        END DO
        FORALL (iw=1:Nw) FnuBAND0(:,iw) = Const1D(iw)
        !! STAR *lnFstar
        FORALL (igrid=1:Ngrid) &
          FnuSTAR0(igrid,:) = EXP(parvec(igrid)) * &
                              pi * BLACKBODY(nu(:), Tstar) /MKS%stefan/Tstar**4
        !! STAR
        Const1D(:) = 0._DP
        DO j=1,Nstar
          IF (j.NE.i) &
            Const1D(:) = Const1D(:) + EXP(parval(indpar%lnFstar(j))) * &
                         pi * BLACKBODY(nu(:), Tstar) /MKS%stefan/Tstar**4

        END DO
        FORALL (iw=1:Nw) FnuSTAR0(:,iw) = FnuSTAR0(:,iw) + Const1D(iw)
        !! LINE
        Const1D(:) = 0._DP
        DO j=1,Nline
          Const1D(:) = Const1D(:) + EXP(parval(indpar%lnIline(j))) * &
                       gaussLine(wvl(:), parval(indpar%Cline(j)), &
                         parval(indpar%Wline(j)))

        END DO
        FORALL (iw=1:Nw) FnuLINE0(:,iw) = Const1D(iw)
        !! PABS
        Const1D(:) = 0._DP
        DO j=1,Npabs
          Const1D(:) = Const1D(:) + EXP(parval(indpar%lnAv(j)))

        END DO
        FORALL (iw=1:Nw) Pabs0(:,iw) = EXP( -Const1D(iw)/1.086_DP * extinct(iw) )
        !! Total model
        specModel_gen(:,:) = (FnuCONT0(:,:) + FnuBAND0(:,:) + FnuSTAR0(:,:)) * &
                             Pabs0(:,:) + FnuLINE0(:,:)

      END IF

      !! BLS (Bug Localization System)
      IF (bls) THEN
        IF (ANY(isNaN(specModel_gen))) THEN
          IF (gridlnFstar) PRINT*, "lnFstar"//TRIMLR(PRING(j))

          IF (ANY(isNaN(FnuCONT0))) THEN
            PRINT*, 'FnuCONT0'
          END IF
          IF (ANY(isNaN(FnuBAND0))) THEN
            PRINT*, 'FnuBAND0'
          END IF
          IF (ANY(isNaN(FnuSTAR0))) THEN
            PRINT*, 'FnuSTAR0'
          END IF
          IF (ANY(isNaN(PABS0))) THEN
            PRINT*, 'PABS0'
          END IF
          IF (ANY(isNaN(FnuLINE0))) THEN
            PRINT*, 'FnuLINE0'
          END IF
          STOP
        END IF
      END IF

    END DO loopSTAR

    IF (printimer) &
      PRINT*, "[specModel] CAL STAR IN "//TRIMLR(TIMINFO(timestr))//"."

    !! 4. Screen extinction
    !!----------------------
    loopPABS: DO i=1,Npabs
      gridlnAv = TRIMEQ(parname, 'lnAv'//TRIMLR(PRING(i)))

      IF (gridlnAv) THEN
        !! CONT
        Const1D(:) = 0._DP
        DO j=1,Ncont
          Const1D(:) = Const1D(:) + EXP(parval(indpar%lnMovd2(j))) * MKS%Msun/MKS%pc**2 * &
                       modifBB(wvl(:), EXP(parval(indpar%lnT(j))), Qabs(j))

        END DO
        FORALL (iw=1:Nw) FnuCONT0(:,iw) = Const1D(iw)
        !! BAND
        Const1D(:) = 0._DP
        DO j=1,Nband
          Const1D(:) = Const1D(:) + EXP(parval(indpar%lnIband(j))) * &
                       lorentzBand(wvl(:), parval(indpar%Cband(j)), &
                         parval(indpar%WSband(j)), parval(indpar%WLband(j)))

        END DO
        FORALL (iw=1:Nw) FnuBAND0(:,iw) = Const1D(iw)
        !! STAR
        Const1D(:) = 0._DP
        DO j=1,Nstar
          Const1D(:) = Const1D(:) + EXP(parval(indpar%lnFstar(j))) * &
                       pi * BLACKBODY(nu(:), Tstar) /MKS%stefan/Tstar**4

        END DO
        FORALL (iw=1:Nw) FnuSTAR0(:,iw) = Const1D(iw)
        !! LINE
        Const1D(:) = 0._DP
        DO j=1,Nline
          Const1D(:) = Const1D(:) + EXP(parval(indpar%lnIline(j))) * &
                       gaussLine(wvl(:), parval(indpar%Cline(j)), &
                         parval(indpar%Wline(j)))

        END DO
        FORALL (iw=1:Nw) FnuLINE0(:,iw) = Const1D(iw)
        !! PABS *lnAv
        FORALL (igrid=1:Ngrid) &
          Pabs0(igrid,:) = EXP( -EXP(parvec(igrid))/1.086_DP * extinct(:) )
        !! PABS
        Const1D(:) = 0._DP
        DO j=1,Npabs
          IF (j.NE.i) Const1D(:) = Const1D(:) + EXP(parval(indpar%lnAv(j)))

        END DO
        FORALL (iw=1:Nw) Pabs0(:,iw) = Pabs0(:,iw) * EXP( -Const1D(:)/1.086_DP * extinct(iw) )
        !! Total model
        specModel_gen(:,:) = (FnuCONT0(:,:) + FnuBAND0(:,:) + FnuSTAR0(:,:)) * &
                             Pabs0(:,:) + FnuLINE0(:,:)

      END IF

      !! BLS (Bug Localization System)
      IF (bls) THEN
        IF (ANY(isNaN(specModel_gen))) THEN
          IF (gridlnAv) PRINT*, "lnAv"//TRIMLR(PRING(i))

          IF (ANY(isNaN(FnuCONT0))) THEN
            PRINT*, 'FnuCONT0'
          END IF
          IF (ANY(isNaN(FnuBAND0))) THEN
            PRINT*, 'FnuBAND0'
          END IF
          IF (ANY(isNaN(FnuSTAR0))) THEN
            PRINT*, 'FnuSTAR0'
          END IF
          IF (ANY(isNaN(PABS0))) THEN
            PRINT*, 'PABS0'
          END IF
          IF (ANY(isNaN(FnuLINE0))) THEN
            PRINT*, 'FnuLINE0'
          END IF
          STOP
        END IF
      END IF

    END DO loopPABS

    IF (printimer) &
      PRINT*, "[specModel] CAL PABS IN "//TRIMLR(TIMINFO(timestr))//"."

    !! 5. Lines
    !!----------
    loopLINE: DO i=1,Nline
      gridlnIline = TRIMEQ(parname, 'lnIline'//TRIMLR(PRING(i)))
      gridCline = TRIMEQ(parname, 'Cline'//TRIMLR(PRING(i)))
      gridWline = TRIMEQ(parname, 'Wline'//TRIMLR(PRING(i)))

      IF (gridlnIline) THEN
        !! CONT
        Const1D(:) = 0._DP
        DO j=1,Ncont
          Const1D(:) = Const1D(:) + EXP(parval(indpar%lnMovd2(j))) * MKS%Msun/MKS%pc**2 * &
                       modifBB(wvl(:), EXP(parval(indpar%lnT(j))), Qabs(j))

        END DO
        FORALL (iw=1:Nw) FnuCONT0(:,iw) = Const1D(iw)
        !! BAND
        Const1D(:) = 0._DP
        DO j=1,Nband
          Const1D(:) = Const1D(:) + EXP(parval(indpar%lnIband(j))) * &
                       lorentzBand(wvl(:), parval(indpar%Cband(j)), &
                         parval(indpar%WSband(j)), parval(indpar%WLband(j)))

        END DO
        FORALL (iw=1:Nw) FnuBAND0(:,iw) = Const1D(iw)
        !! STAR
        Const1D(:) = 0._DP
        DO j=1,Nstar
          Const1D(:) = Const1D(:) + EXP(parval(indpar%lnFstar(j))) * &
                       pi * BLACKBODY(nu(:), Tstar) /MKS%stefan/Tstar**4

        END DO
        FORALL (iw=1:Nw) FnuSTAR0(:,iw) = Const1D(iw)
        !! LINE *lnIline
        Const1D(:) =  gaussLine(wvl(:), parval(indpar%Cline(i)), &
                        parval(indpar%Wline(i)))
! if (isnan(EXP(parval(indpar%lnIline(j))))) print*, "exp*"
! if (any(isnan(gaussLine(wvl(:), parval(indpar%Cline(j)), parval(indpar%Wline(j)))))) print*, "gauss*"
        FORALL (igrid=1:Ngrid) &
          FnuLINE0(igrid,:) = EXP(parvec(igrid)) * Const1D(:)
        !! LINE
        Const1D(:) = 0._DP
        DO j=1,Nline
          IF (j.NE.i) &
          Const1D(:) = Const1D(:) + EXP(parval(indpar%lnIline(j))) * &
                       gaussLine(wvl(:), parval(indpar%Cline(j)), &
                         parval(indpar%Wline(j)))
! if (isnan(EXP(parval(indpar%lnIline(j))))) print*, "exp"
! if (any(isnan(gaussLine(wvl(:), parval(indpar%Cline(j)), parval(indpar%Wline(j)))))) print*, "gauss"
        END DO
        FORALL (iw=1:Nw) FnuLINE0(:,iw) = FnuLINE0(:,iw) + Const1D(iw)
        !! PABS
        Const1D(:) = 0._DP
        DO j=1,Npabs
          Const1D(:) = Const1D(:) + EXP(parval(indpar%lnAv(j)))

        END DO
        FORALL (iw=1:Nw) Pabs0(:,iw) = EXP( -Const1D(iw)/1.086_DP * extinct(iw) )
        !! Total model
        specModel_gen(:,:) = (FnuCONT0(:,:) + FnuBAND0(:,:) + FnuSTAR0(:,:)) * &
                             Pabs0(:,:) + FnuLINE0(:,:)

      ELSE IF (gridCline) THEN
        !! CONT
        Const1D(:) = 0._DP
        DO j=1,Ncont
          Const1D(:) = Const1D(:) + EXP(parval(indpar%lnMovd2(j))) * MKS%Msun/MKS%pc**2 * &
                       modifBB(wvl(:), EXP(parval(indpar%lnT(j))), Qabs(j))

        END DO
        FORALL (iw=1:Nw) FnuCONT0(:,iw) = Const1D(iw)
        !! BAND
        Const1D(:) = 0._DP
        DO j=1,Nband
          Const1D(:) = Const1D(:) + EXP(parval(indpar%lnIband(j))) * &
                       lorentzBand(wvl(:), parval(indpar%Cband(j)), &
                         parval(indpar%WSband(j)), parval(indpar%WLband(j)))

        END DO
        FORALL (iw=1:Nw) FnuBAND0(:,iw) = Const1D(iw)
        !! STAR
        Const1D(:) = 0._DP
        DO j=1,Nstar
          Const1D(:) = Const1D(:) + EXP(parval(indpar%lnFstar(j))) * &
                       pi * BLACKBODY(nu(:), Tstar) /MKS%stefan/Tstar**4

        END DO
        FORALL (iw=1:Nw) FnuSTAR0(:,iw) = Const1D(iw)
        !! LINE *Cline
        Const = EXP(parval(indpar%lnIline(i)))
        FORALL (igrid=1:Ngrid) &
          FnuLINE0(igrid,:) = Const * gaussLine(wvl(:), parvec(igrid), &
                                       parval(indpar%Wline(i)))
        !! LINE
        Const1D(:) = 0._DP
        DO j=1,Nline
          IF (j.NE.i) &
          Const1D(:) = Const1D(:) + EXP(parval(indpar%lnIline(j))) * &
                       gaussLine(wvl(:), parval(indpar%Cline(j)), &
                         parval(indpar%Wline(j)))
! if (isnan(EXP(parval(indpar%lnIline(j))))) print*, "exp"
! if (any(isnan(gaussLine(wvl(:), parval(indpar%Cline(j)), parval(indpar%Wline(j)))))) print*, "gauss"
        END DO
        FORALL (iw=1:Nw) FnuLINE0(:,iw) = FnuLINE0(:,iw) + Const1D(iw)
        !! PABS
        Const1D(:) = 0._DP
        DO j=1,Npabs
          Const1D(:) = Const1D(:) + EXP(parval(indpar%lnAv(j)))

        END DO
        FORALL (iw=1:Nw) Pabs0(:,iw) = EXP( -Const1D(iw)/1.086_DP * extinct(iw) )
        !! Total model
        specModel_gen(:,:) = (FnuCONT0(:,:) + FnuBAND0(:,:) + FnuSTAR0(:,:)) * &
                             Pabs0(:,:) + FnuLINE0(:,:)

      ELSE IF (gridWline) THEN
        !! CONT
        Const1D(:) = 0._DP
        DO j=1,Ncont
          Const1D(:) = Const1D(:) + EXP(parval(indpar%lnMovd2(j))) * MKS%Msun/MKS%pc**2 * &
                       modifBB(wvl(:), EXP(parval(indpar%lnT(j))), Qabs(j))

        END DO
        FORALL (iw=1:Nw) FnuCONT0(:,iw) = Const1D(iw)
        !! BAND
        Const1D(:) = 0._DP
        DO j=1,Nband
          Const1D(:) = Const1D(:) + EXP(parval(indpar%lnIband(j))) * &
                       lorentzBand(wvl(:), parval(indpar%Cband(j)), &
                         parval(indpar%WSband(j)), parval(indpar%WLband(j)))

        END DO
        FORALL (iw=1:Nw) FnuBAND0(:,iw) = Const1D(iw)
        !! STAR
        Const1D(:) = 0._DP
        DO j=1,Nstar
          Const1D(:) = Const1D(:) + EXP(parval(indpar%lnFstar(j))) * &
                       pi * BLACKBODY(nu(:), Tstar) /MKS%stefan/Tstar**4

        END DO
        FORALL (iw=1:Nw) FnuSTAR0(:,iw) = Const1D(iw)
        !! LINE *Wline
        Const = EXP(parval(indpar%lnIline(i)))
        FORALL (igrid=1:Ngrid) &
          FnuLINE0(igrid,:) = Const * gaussLine(wvl(:), parvec(igrid), &
                                       parval(indpar%Wline(i)))
        !! LINE
        Const1D(:) = 0._DP
        DO j=1,Nline
          IF (j.NE.i) &
          Const1D(:) = Const1D(:) + EXP(parval(indpar%lnIline(j))) * &
                       gaussLine(wvl(:), parval(indpar%Cline(j)), &
                         parval(indpar%Wline(j)))

        END DO
        FORALL (iw=1:Nw) FnuLINE0(:,iw) = FnuLINE0(:,iw) + Const1D(iw)
        !! PABS
        Const1D(:) = 0._DP
        DO j=1,Npabs
          Const1D(:) = Const1D(:) + EXP(parval(indpar%lnAv(j)))

        END DO
        FORALL (iw=1:Nw) Pabs0(:,iw) = EXP( -Const1D(iw)/1.086_DP * extinct(iw) )
        !! Total model
        specModel_gen(:,:) = (FnuCONT0(:,:) + FnuBAND0(:,:) + FnuSTAR0(:,:)) * &
                             Pabs0(:,:) + FnuLINE0(:,:)

      END IF

      !! BLS (Bug Localization System)
      IF (bls) THEN
        IF (ANY(isNaN(specModel_gen))) THEN
          IF (gridlnIline) THEN
            PRINT*, "lnIline"//TRIMLR(PRING(i))
          ELSE IF (gridCline) THEN
            PRINT*, "Cline"//TRIMLR(PRING(i))
          ELSE IF (gridWline) THEN
            PRINT*, "Wline"//TRIMLR(PRING(i))
          END IF

          IF (ANY(isNaN(FnuCONT0))) THEN
            PRINT*, 'FnuCONT0'
          END IF
          IF (ANY(isNaN(FnuBAND0))) THEN
            PRINT*, 'FnuBAND0'
          END IF
          IF (ANY(isNaN(FnuSTAR0))) THEN
            PRINT*, 'FnuSTAR0'
          END IF
          IF (ANY(isNaN(PABS0))) THEN
            PRINT*, 'PABS0'
          END IF
          IF (ANY(isNaN(FnuLINE0))) THEN
            PRINT*, 'FnuLINE0'
          END IF
          STOP
        END IF
      END IF

    END DO loopLINE

    IF (printimer) &
      PRINT*, "[specModel] CAL LINE IN "//TRIMLR(TIMINFO(timestr))//"."

  END FUNCTION specModel_gen

  !!-------------------------------------------------------
  !!
  !!                      Grid settings
  !!
  !!-------------------------------------------------------
    dogrid = ( SIZE(parvec(:)) > 1 ) ! par grid for Gibbs sampling
    ! IF (tied .AND. dogrid) THEN
    IF (dogrid) THEN
      IF (CONTset) THEN
        ALLOCATE(CONTgrid(Ncont))
        DO i=1,Ncont
          CONTgrid(i) = ( TRIMEQ(parname, "Mcont"//TRIMLR(PRING(i))) &
                          .OR. TRIMEQ(parname, "Tcont"//TRIMLR(PRING(i))) )

        END DO
      ELSE
        ALLOCATE(CONTgrid(1))
        CONTgrid(:) = .FALSE.

      END IF
      IF (BANDset) THEN
        ALLOCATE(BANDgrid(Nband))
        DO i=1,Nband
          BANDgrid(i) = ( TRIMEQ(parname, "Iband"//TRIMLR(PRING(i))) &
                          .OR. TRIMEQ(parname, "Cband"//TRIMLR(PRING(i))) &
                          .OR. TRIMEQ(parname, "WSband"//TRIMLR(PRING(i))) &
                          .OR. TRIMEQ(parname, "WLband"//TRIMLR(PRING(i))) )

        END DO
      ELSE
        ALLOCATE(BANDgrid(1))
        BANDgrid(:) = .FALSE.

      END IF
      STARgrid = ( TRIMEQ(compname, "Fstar") )
      PABSgrid = ( TRIMEQ(compname, "Av") )
      IF (LINEset) THEN
        ALLOCATE(LINEgrid(Nline))
        DO i=1,Nline
          LINEgrid(i) = ( TRIMEQ(parname, "Iline"//TRIMLR(PRING(i))) &
                          .OR. TRIMEQ(parname, "Cline"//TRIMLR(PRING(i))) &
                          .OR. TRIMEQ(parname, "Wline"//TRIMLR(PRING(i))) )

        END DO
      ELSE
        ALLOCATE(LINEgrid(1))
        LINEgrid(:) = .FALSE.

      END IF
    END IF

  !!-------------------------------------------------------
  !!
  !!            [obsolet] Read optical properties
  !!
  !!-------------------------------------------------------
  SUBROUTINE make_Qabs(label, nQabs, waveall)
    !! wave [um], nu [Hz], Qova [m^-1], rho [kg/m^3]
    USE utilities, ONLY: DP
    USE constants, ONLY: MKS
    USE arrays, ONLY: closest
    USE interpolation, ONLY: interp_lin_sorted
    USE grain_optics, ONLY: rho_grain, read_optics
    IMPLICIT NONE

    CHARACTER(*), DIMENSION(:), INTENT(IN)               :: label
    REAL(DP), DIMENSION(:), INTENT(IN), OPTIONAL         :: waveall
    INTEGER                                              :: i, Nspec, Nr, Nw
    INTEGER, DIMENSION(SIZE(label))                      :: indr ! radius index
    REAL(DP), PARAMETER                                  :: a0 = 1.E-2_DP ! grain radius
    REAL(DP), DIMENSION(:), ALLOCATABLE                  :: wave0
    REAL(DP), DIMENSION(:,:), ALLOCATABLE                :: radius
    REAL(DP), DIMENSION(:,:,:), ALLOCATABLE              :: Q ! (Nspec, Nr, Nw)
    TYPE(Qabs_type), DIMENSION(SIZE(label)), INTENT(OUT) :: nQabs

    CALL read_optics(label, WAVE=wave0, RADIUSALL=radius, QABSALL=Q)

    Nspec = SIZE(label)
    Nw = SIZE(wave0)

    DO i=1,Nspec

      ALLOCATE(nQabs(i)%Qova(Nw))

      Nr = SIZE(radius(i,:))
      nQabs(i)%rho = rho_grain(label(i))
      nQabs(i)%wave = wave0
      nQabs(i)%nu = MKS%clight/MKS%micron / wave0
      indr(i) = closest(radius(i,:), a0)
      nQabs(i)%Qova = Q(i,indr(i),:)/radius(i,indr(i))
      ! PRINT*, 'Radius of ', label(i), ': ', radius(i,indr(i)), '->', indr(i)

      !! [Optional] Interpolate nQabs to input wave grid
      IF (PRESENT(waveall)) THEN
        nQabs(i)%wave = waveall
        nQabs(i)%nu = MKS%clight/MKS%micron / waveall
        nQabs(i)%Qova = interp_lin_sorted(nQabs(i)%Qova, wave0, waveall, &
                                          XLOG=.TRUE., YLOG=.TRUE., FORCE=.TRUE.)

      END IF

    END DO

    !! Free memory space
    DEALLOCATE(wave0, radius, Q)

  END SUBROUTINE make_Qabs

  !!-------------------------------------------------------
  !!
  !!       [obsolet] Create the parameter structure
  !!
  !!-------------------------------------------------------
  SUBROUTINE make_par(parvec, Nbb, Nline, Nband, NAv, Nstar, &
                      par, Npar, parinfo)

    USE utilities, ONLY: DP, PRING, TRIMLR
    IMPLICIT NONE

    INTEGER, INTENT(IN) :: Nbb, Nline, Nband, NAv, Nstar
    REAL(DP), DIMENSION(:), INTENT(IN) :: parvec ! param vector
    INTEGER i, i0, Npar0
    TYPE(par_type) :: par0
    TYPE(par_type), INTENT(OUT), OPTIONAL :: par
    INTEGER, INTENT(OUT), OPTIONAL :: Npar
    TYPE(parinfo_type), DIMENSION(:), ALLOCATABLE, INTENT(OUT), OPTIONAL :: parinfo

    ! Npar0 = 2*Nbb + 3*Nline + 4*Nband + NAv + Nstar
    Npar0 = SIZE(parvec)
    IF (PRESENT(Npar)) Npar = Npar0
    IF (PRESENT(parinfo)) ALLOCATE(parinfo(Npar0))

    ALLOCATE(par0%Mcont(Nbb), par0%Tcont(Nbb)) ! Nbb*2
    ALLOCATE(par0%Iline(Nline), par0%Cline(Nline), par0%Wline(Nline)) ! Nline*3
    ALLOCATE(par0%Iband(Nband), par0%Cband(Nband), &
             par0%WSband(Nband), par0%WLband(Nband)) ! Nband*4
    ALLOCATE(par0%Av(NAv)) ! NAv*1
    ALLOCATE(par0%Fstar(Nstar)) ! Nstar*1

    !! 1) Continuum
    i0 = 0
    DO i=1,Nbb
      par0%Mcont(i) = parvec(i0+2*i-1) ! i0 + 2*(i-1) + 1
      par0%Tcont(i) = parvec(i0+2*i)

      IF (PRESENT(parinfo)) THEN
        parinfo(i0+2*i-1)%name = 'Mcont'//TRIMLR(PRING(i))
        parinfo(i0+2*i-1)%limits = [0._DP,1._DP]
        parinfo(i0+2*i-1)%limited = [.True.,.False.]
        parinfo(i0+2*i)%name = 'Tcont'//TRIMLR(PRING(i))
        parinfo(i0+2*i)%limits = [50._DP,500._DP]
        parinfo(i0+2*i)%limited = [.True.,.True.]

      END IF

    END DO

    !! 2) Lines
    i0 = i0 + 2*Nbb
    DO i=1,Nline
      par0%Iline(i) = parvec(i0+3*i-2)
      par0%Cline(i) = parvec(i0+3*i-1)
      par0%Wline(i) = parvec(i0+3*i)

      IF (PRESENT(parinfo)) THEN
        parinfo(i0+3*i-2)%name = 'Iline'//TRIMLR(PRING(i))
        parinfo(i0+3*i-2)%limits = [0._DP,1._DP]
        parinfo(i0+3*i-2)%limited = [.True.,.False.]
        parinfo(i0+3*i-1)%name = 'Cline'//TRIMLR(PRING(i))
        parinfo(i0+3*i-1)%limits = &
          [ par0%Cline(i) - par0%Wline(i)/par0%Cline(i)/2._DP, &
            par0%Cline(i) + par0%Wline(i)/par0%Cline(i)/2._DP ]
        parinfo(i0+3*i-1)%limited = [.True.,.True.]
        parinfo(i0+3*i)%name = 'Wline'//TRIMLR(PRING(i))
        parinfo(i0+3*i)%fixed = .True.

      END IF

    END DO

    !! 3) Bands
    i0 = i0 + 3*Nline
    DO i=1,Nband
      par0%Iband(i) = parvec(i0+4*i-3)
      par0%Cband(i) = parvec(i0+4*i-2)
      par0%WSband(i) = parvec(i0+4*i-1)
      par0%WLband(i) = parvec(i0+4*i)

      IF (PRESENT(parinfo)) THEN
        parinfo(i0+4*i-3)%name = 'Iband'//TRIMLR(PRING(i))
        parinfo(i0+4*i-3)%limits = [0._DP,1._DP]
        parinfo(i0+4*i-3)%limited = [.True.,.False.]
        parinfo(i0+4*i-2)%name = 'Cband'//TRIMLR(PRING(i))
        parinfo(i0+4*i-2)%fixed = .True.
        parinfo(i0+4*i-1)%name = 'WSband'//TRIMLR(PRING(i))
        parinfo(i0+4*i-1)%fixed = .True.
        parinfo(i0+4*i)%name = 'WLband'//TRIMLR(PRING(i))
        parinfo(i0+4*i)%fixed = .True.

      END IF

    END DO

    !! 4) Av
    i0 = i0 + 4*Nband
    DO i=1,NAv
      par0%Av(i) = parvec(i0+i)

      IF (PRESENT(parinfo)) THEN
        parinfo(i0+i)%name = 'Av'
        parinfo(i0+i)%fixed = .True.

      END IF

    END DO

    !! 5) Star
    i0 = i0 + NAv
    IF (Nstar .GT. 0) THEN
      DO i=1,Nstar
        par0%Fstar(i) = parvec(i0+1)

        IF (PRESENT(parinfo)) THEN
          parinfo(i0+i)%name = 'Fstar'
          parinfo(i0+i)%limits = [0._DP,1._DP]
          parinfo(i0+i)%limited = [.True.,.False.]

        END IF

      END DO
    END IF

    IF (PRESENT(par)) par = par0

  END SUBROUTINE make_par


!*****************************************************************************************
!> author: Jacob Williams
!  date: 1/1/2018
!
!  Unit test for [[ddeabm_class]].
!  Tests the different options for specifying the initial step size.

    program ddeabm_stepsize_test

    use ddeabm_kinds
    use ddeabm_module

    implicit none

    type,extends(ddeabm_with_event_class) :: spacecraft
        !! spacecraft propagation type.
        !! extends the [[ddeabm_class]] to include data used in the deriv routine
        real(wp) :: mu = 0.0_wp      !! central body gravitational parameter (km3/s2)
        integer :: fevals = 0        !! number of function evaluations
        logical :: first = .true.    !! first point is being exported
    end type spacecraft

    integer,parameter  :: n = 6            !! number of state variables
    real(wp),parameter :: tol = 1.0e-12_wp !! event location tolerance
    integer,parameter :: integration_mode = 1  !! don't report points
    real(wp),parameter :: initial_step_size = 1.56e-4_wp !! for `initial_step_mode` 3

    type(spacecraft) :: s
    real(wp),dimension(n) :: x0,xf,x02,x
    real(wp) :: t0,tf,dt,gf,tf_actual,t,gval,z_target
    integer :: idid,initial_step_mode

    write(*,*) ''
    write(*,*) '---------------'
    write(*,*) ' ddeabm_test'
    write(*,*) '---------------'
    write(*,*) ''

    !***************************************************************************

    do initial_step_mode = 1, 3  ! test each mode

        !constructor (main body is Earth):
        call s%initialize(n,maxnum=10000,df=twobody,&
                            rtol=[1.0e-12_wp],atol=[1.0e-12_wp],&
                            report=twobody_report,&
                            initial_step_mode=initial_step_mode,&
                            initial_step_size=initial_step_size)
        s%mu = 398600.436233_wp  !earth

        !initial conditions:
        x0 = [10000.0_wp,10000.0_wp,10000.0_wp,&   !initial state [r,v] (km,km/s)
                1.0_wp,2.0_wp,3.0_wp]
        t0 = 0.0_wp       !initial time (sec)
        tf = 1000.0_wp    !final time (sec)
        s%fevals = 0

        if (initial_step_mode==1) then
            write(*,'(A/,*(F15.6/))') 'Initial time:',t0
            write(*,'(A/,*(F15.6/))') 'Initial state:',x0
        end if
        s%fevals = 0
        s%first = .true.
        t = t0
        x = x0
        call s%first_call()  ! restart integration
        call s%integrate(t,x,tf,idid=idid,integration_mode=integration_mode)
        xf = x
        write(*,*) ''
        write(*,*) '------------------------------------------------------'
        write(*,'(A/,*(I5/))')    'initial_step_mode: ',initial_step_mode
        write(*,'(A/,*(I5/))')    'idid: ',idid
        write(*,'(A/,*(F15.6/))') 'Final time:',t
        write(*,'(A/,*(F15.6/))') 'Final state:',xf
        write(*,'(A,I5)') 'Function evaluations:', s%fevals
        write(*,*) ''

    end do

    contains
!*****************************************************************************************

    !*********************************************************
        subroutine twobody(me,t,x,xdot)

        !! derivative routine for two-body orbit propagation

        implicit none

        class(ddeabm_class),intent(inout) :: me
        real(wp),intent(in)               :: t
        real(wp),dimension(:),intent(in)  :: x
        real(wp),dimension(:),intent(out) :: xdot

        real(wp),dimension(3) :: r,v,a_grav
        real(wp) :: rmag

        select type (me)
        class is (spacecraft)

            r = x(1:3)
            v = x(4:6)
            rmag = norm2(r)
            a_grav = -me%mu/rmag**3 * r !acceleration due to gravity

            xdot(1:3) = v
            xdot(4:6) = a_grav

            me%fevals = me%fevals + 1

        end select

        end subroutine twobody
    !*********************************************************

    !*********************************************************
        subroutine twobody_report(me,t,x)

        !! report function - write time,state to console

        implicit none

        class(ddeabm_class),intent(inout)    :: me
        real(wp),intent(in)                  :: t
        real(wp),dimension(:),intent(in)     :: x

        select type (me)
        class is (spacecraft)
            if (me%first) then  !print header
                write(*,*) ''
                write(*,'(*(A15,1X))')  'time (sec)','x (km)','y (km)','z (km)',&
                                        'vx (km/s)','vy (km/s)','vz (km/s)'
                me%first = .false.
            end if
        end select

        write(*,'(*(F15.6,1X))') t,x

        end subroutine twobody_report
    !*********************************************************

    end program ddeabm_stepsize_test
!*****************************************************************************************


!----------------------------------------------------------------------!
! Library with sorting routines.                                       !
! -------------------------------------------------------------------- !
! sort(A)        : sort double precision array A                       !
! sort(A,n)      : sort first n elements in double precision array A   !
! argsort(A,idx) : return index idx that sorts dp array A              !
! -------------------------------------------------------------------- !
! 2010-02-11 Alexander Urban (AU)                                      !
!----------------------------------------------------------------------!

module sortlib

  implicit none

  public  :: sort,           &
             sort_i,         &
             sort_d,         &
             argsort,        &
             argsort_d,      &
             argsort_i

  private :: qsort_d,        &
             qsort_i,        &
             qargsort_d,     &
             qargsort_i,     &
             partition_d,    &
             partition_i,    &
             argpartition_d, &
             argpartition_i

  interface sort
     module procedure sort_i, sort_d
  end interface
  interface argsort
     module procedure argsort_i, argsort_d
  end interface

contains

  !--------------------------------------------------------------------!
  !                          User interfaces                           !
  !--------------------------------------------------------------------!

  subroutine sort_d(A, n)

    implicit none

    double precision, dimension(:), intent(inout) :: A
    integer, optional,              intent(in)    :: n
    integer                                       :: m

    if (present(n)) then
       m = n
    else
       m = size(A)
    end if

    call qsort_d(A, m)

  end subroutine sort_d

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

  subroutine sort_i(A, n)

    implicit none

    integer, dimension(:), intent(inout) :: A
    integer, optional,     intent(in)    :: n
    integer                              :: m

    if (present(n)) then
       m = n
    else
       m = size(A)
    end if

    call qsort_i(A, m)

  end subroutine sort_i

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

  subroutine argsort_d(A, idx)

    implicit none

    double precision, dimension(:), intent(in)  :: A
    integer,          dimension(:), intent(out) :: idx
    integer                                     :: i, n

    n = size(idx)
    do i = 1, n
       idx(i) = i
    end do

    call qargsort_d(A, idx, n, n)

  end subroutine argsort_d

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

  subroutine argsort_i(A, idx)

    implicit none

    integer, dimension(:), intent(in)  :: A
    integer, dimension(:), intent(out) :: idx
    integer                            :: i, n

    n = size(idx)
    do i = 1, n
       idx(i) = i
    end do

    call qargsort_i(A, idx, n, n)

  end subroutine argsort_i

  !--------------------------------------------------------------------!
  !                      quicksort implementation                      !
  !--------------------------------------------------------------------!

  recursive subroutine qsort_d(A,n)

    implicit none

    integer,                        intent(in)    :: n
    double precision, dimension(n), intent(inout) :: A
    integer                                       :: iq

    if(n > 1) then
       call partition_d(A, n, iq)
       call qsort_d(A(:iq-1), iq-1)
       call qsort_d(A(iq:), n-iq+1)
    endif

  end subroutine qsort_d

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

  recursive subroutine qsort_i(A,n)

    implicit none

    integer,               intent(in)    :: n
    integer, dimension(n), intent(inout) :: A
    integer                              :: iq

    if(n > 1) then
       call partition_i(A, n, iq)
       call qsort_i(A(:iq-1), iq-1)
       call qsort_i(A(iq:), n-iq+1)
    endif

  end subroutine qsort_i

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

  subroutine partition_d(A, n, marker)

    implicit none

    integer,                        intent(in)    :: n
    double precision, dimension(n), intent(inout) :: A
    integer,                        intent(out)   :: marker
    integer                                       :: i, j
    double precision                              :: temp
    double precision                              :: x    ! pivot point

    x = A(1)
    i = 0
    j = n + 1

    do
       j = j-1
       do while (A(j) > x)
          j = j-1
       end do
       i = i+1
       do while (A(i) < x)
          i = i+1
       end do
       if (i < j) then
          ! exchange A(i) and A(j)
          temp = A(i)
          A(i) = A(j)
          A(j) = temp
       else if (i == j) then
          marker = i+1
          return
       else
          marker = i
          return
       endif
    end do

  end subroutine partition_d

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

  subroutine partition_i(A, n, marker)

    implicit none

    integer,               intent(in)    :: n
    integer, dimension(n), intent(inout) :: A
    integer,               intent(out)   :: marker
    integer                              :: i, j
    double precision                     :: temp
    double precision                     :: x    ! pivot point

    x = A(1)
    i = 0
    j = n + 1

    do
       j = j-1
       do while (A(j) > x)
          j = j-1
       end do
       i = i+1
       do while (A(i) < x)
          i = i+1
       end do
       if (i < j) then
          ! exchange A(i) and A(j)
          temp = A(i)
          A(i) = A(j)
          A(j) = temp
       else if (i == j) then
          marker = i+1
          return
       else
          marker = i
          return
       endif
    end do

  end subroutine partition_i

  !--------------------------------------------------------------------!
  !                   Argument sort using quicksort                    !
  !--------------------------------------------------------------------!

  recursive subroutine qargsort_d(A, idx, n, m)

    implicit none

    integer,                        intent(in)    :: n
    integer,                        intent(in)    :: m
    double precision, dimension(n), intent(in)    :: A
    integer,          dimension(m), intent(inout) :: idx
    integer                                       :: iq

    if(m > 1) then
       call argpartition_d(A, idx, n, m, iq)
       call qargsort_d(A, idx(:iq-1), n, iq-1)
       call qargsort_d(A, idx(iq:),   n, m-iq+1)
    endif

  end subroutine qargsort_d

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

  recursive subroutine qargsort_i(A, idx, n, m)

    implicit none

    integer,               intent(in)    :: n
    integer,               intent(in)    :: m
    integer, dimension(n), intent(in)    :: A
    integer, dimension(m), intent(inout) :: idx
    integer                              :: iq

    if(m > 1) then
       call argpartition_i(A, idx, n, m, iq)
       call qargsort_i(A, idx(:iq-1), n, iq-1)
       call qargsort_i(A, idx(iq:),   n, m-iq+1)
    endif

  end subroutine qargsort_i

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

  subroutine argpartition_d(A, idx, n, m, marker)

    implicit none

    integer,                        intent(in)    :: n
    integer,                        intent(in)    :: m
    double precision, dimension(n), intent(in)    :: A
    integer,          dimension(m), intent(inout) :: idx
    integer,                        intent(out)   :: marker
    integer                                       :: i, j
    integer                                       :: temp
    double precision                              :: x    ! pivot point

    x = A(idx(1))
    i = 0
    j = m + 1

    do
       j = j-1
       do while (A(idx(j)) > x)
          j = j-1
       end do
       i = i+1
       do while (A(idx(i)) < x)
          i = i+1
       end do
       if (i < j) then
          ! exchange A(idx(i)) and A(idx(j))
          temp   = idx(i)
          idx(i) = idx(j)
          idx(j) = temp
       else if (i == j) then
          marker = i+1
          return
       else
          marker = i
          return
       endif
    end do

  end subroutine argpartition_d

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

  subroutine argpartition_i(A, idx, n, m, marker)

    implicit none

    integer,               intent(in)    :: n
    integer,               intent(in)    :: m
    integer, dimension(n), intent(in)    :: A
    integer, dimension(m), intent(inout) :: idx
    integer,               intent(out)   :: marker
    integer                              :: i, j
    integer                              :: temp
    double precision                     :: x    ! pivot point

    x = A(idx(1))
    i = 0
    j = m + 1

    do
       j = j-1
       do while (A(idx(j)) > x)
          j = j-1
       end do
       i = i+1
       do while (A(idx(i)) < x)
          i = i+1
       end do
       if (i < j) then
          ! exchange A(idx(i)) and A(idx(j))
          temp   = idx(i)
          idx(i) = idx(j)
          idx(j) = temp
       else if (i == j) then
          marker = i+1
          return
       else
          marker = i
          return
       endif
    end do

  end subroutine argpartition_i

end module sortlib


!
!   FnXSH.f90
!
!
!   Created by Kurt Mitman on 19/03/15.
!   Copyright 2015 __MyCompanyName__. All rights reserved.
!

DOUBLE PRECISION FUNCTION FnXSH(pph)

USE Params
USE Globals
USE funcs
USE Procedures

IMPLICIT NONE

DOUBLE PRECISION, INTENT(IN) :: pph
DOUBLE PRECISION             :: vals(2)
INTEGER                      :: inds(2)

call basefun(PhGrid,ngpPh,pph,vals,inds)

FnXSH=sum(vals*XSHdem(inds))

!FnXSH=ispline(pph,PhGrid,XSHdem,scoef1,scoef2,scoef3,ngpPh)

END FUNCTION FnXSH


program i
  integer::a=3+4+4+5
end program i


      REAL FUNCTION covar(x,y,n)
C     .. Scalar Arguments ..
      INTEGER n
C     ..
C     .. Array Arguments ..
      REAL x(n),y(n)
C     ..
C     .. Local Scalars ..
      REAL avx,avy,varx,vary,xmax,xmin
      INTEGER i
C     ..
C     .. External Subroutines ..
      EXTERNAL stat
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC real
C     ..
C     .. Executable Statements ..
      CALL stat(x,n,avx,varx,xmin,xmax)
      CALL stat(y,n,avy,vary,xmin,xmax)
      covar = 0.0
      DO 10,i = 1,n
          covar = covar + (x(i)-avx)* (y(i)-avy)
   10 CONTINUE
      covar = covar/real(n-1)
      RETURN

      END
      SUBROUTINE prcomp(p,mean,xcovar,answer)

      INTEGER p,maxp
      PARAMETER (maxp=10)
      REAL mean(p),xcovar(p,p),rcovar(maxp,maxp)
      REAL answer(1000,maxp)
      REAL rmean(maxp),rvar(maxp)
      INTEGER maxobs
      PARAMETER (maxobs=1000)

      DO 10,i = 1,p
          CALL stat(answer(1,i),maxobs,rmean(i),rvar(i),dum1,dum2)
          WRITE (*,*) ' Variable Number',i
          WRITE (*,*) ' Mean ',mean(i),' Generated ',rmean(i)
          WRITE (*,*) ' Variance ',xcovar(i,i),' Generated',rvar(i)
   10 CONTINUE
      WRITE (*,*) '                   Covariances'
      DO 30,i = 1,p
          DO 20,j = 1,i - 1
              WRITE (*,*) ' I = ',i,' J = ',j
              rcovar(i,j) = covar(answer(1,i),answer(1,j),maxobs)
              WRITE (*,*) ' Covariance ',xcovar(i,j),' Generated ',
     +          rcovar(i,j)
   20     CONTINUE
   30 CONTINUE
      RETURN

      END
      SUBROUTINE setcov(p,var,corr,covar)
C     Set covariance matrix from variance and common correlation
C     .. Scalar Arguments ..
      REAL corr
      INTEGER p
C     ..
C     .. Array Arguments ..
      REAL covar(p,p),var(p)
C     ..
C     .. Local Scalars ..
      INTEGER i,j
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC sqrt
C     ..
C     .. Executable Statements ..
      DO 40,i = 1,p
          DO 30,j = 1,p
              IF (.NOT. (i.EQ.j)) GO TO 10
              covar(i,j) = var(i)
              GO TO 20

   10         covar(i,j) = corr*sqrt(var(i)*var(j))
   20         CONTINUE
   30     CONTINUE
   40 CONTINUE
      RETURN

      END
      SUBROUTINE stat(x,n,av,var,xmin,xmax)
C     .. Scalar Arguments ..
      REAL av,var,xmax,xmin
      INTEGER n
C     ..
C     .. Array Arguments ..
      REAL x(n)
C     ..
C     .. Local Scalars ..
      REAL sum
      INTEGER i
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC real
C     ..
C     .. Executable Statements ..
      xmin = x(1)
      xmax = x(1)
      sum = 0.0
      DO 10,i = 1,n
          sum = sum + x(i)
          IF (x(i).LT.xmin) xmin = x(i)
          IF (x(i).GT.xmax) xmax = x(i)
   10 CONTINUE
      av = sum/real(n)
      sum = 0.0
      DO 20,i = 1,n
          sum = sum + (x(i)-av)**2
   20 CONTINUE
      var = sum/real(n-1)
      RETURN

      END
      PROGRAM tstgmn
C     Test Generation of Multivariate Normal Data
C     .. Parameters ..
      INTEGER maxp
      PARAMETER (maxp=10)
      INTEGER maxobs
      PARAMETER (maxobs=1000)
      INTEGER p2
      PARAMETER (p2=maxp*maxp)
C     ..
C     .. Local Scalars ..
      REAL corr
      INTEGER i,iobs,is1,is2,j,p
      CHARACTER phrase*100
C     ..
C     .. Local Arrays ..
      REAL answer(1000,maxp),ccovar(p2),covar(p2),mean(maxp),param(500),
     +     temp(maxp),var(maxp),work(maxp)
C     ..
C     .. External Subroutines ..
      EXTERNAL genmn,phrtsd,prcomp,setall,setcov,setgmn
C     ..
C     .. Executable Statements ..
      WRITE (*,9000)

 9000 FORMAT (
     +     ' Tests Multivariate Normal Generator for Up to 10 Variables'
     +       /
     +  ' User inputs means, variances, one correlation that is applied'
     +       /'     to all pairs of variables'/
     +       ' 1000 multivariate normal deviates are generated'/
     +     ' Means, variances and covariances are calculated for these.'
     +       )

   10 WRITE (*,*) 'Enter number of variables for normal generator'
      READ (*,*) p
      WRITE (*,*) 'Enter mean vector of length ',p
      READ (*,*) (mean(i),i=1,p)
      WRITE (*,*) 'Enter variance vector of length ',p
      READ (*,*) (var(i),i=1,p)
      WRITE (*,*) 'Enter correlation of all variables'
      READ (*,*) corr
      CALL setcov(p,var,corr,covar)
      WRITE (*,*) ' Enter phrase to initialize rn generator'
      READ (*,'(a)') phrase
      CALL phrtsd(phrase,is1,is2)
      CALL setall(is1,is2)
      DO 20,i = 1,p2
          ccovar(i) = covar(i)
   20 CONTINUE
C
C     Generate Variables
C
      CALL setgmn(mean,ccovar,p,param)
      DO 40,iobs = 1,maxobs
          CALL genmn(param,work,temp)
          DO 30,j = 1,p
              answer(iobs,j) = work(j)
   30     CONTINUE
   40 CONTINUE
      CALL prcomp(p,mean,covar,answer)
C
C     Print Comparison of Generated and Reconstructed Values
C
      GO TO 10

      END