! libRQZ
! author: daan. camps@cs.kuleuven.be
! Description:
!   Change poles in complex Hessenberg pairs
! ___________________________________________________________________
module z_setpoles

use u_parameters
use u_activeparts
use z_memorymgmt
use z_ctransformations
use z_swappoles

implicit none
private
public z_set_first_pole, z_set_last_pole, &
       z_set_first_m_poles, z_set_last_m_poles

contains

  subroutine z_set_first_pole(alpha, beta, A, B, compAB, apC, apT, &
                              Q, compQ, qcol)
  ! DESCRIPTION
  !___________________________________________________________________________
  ! Sets the pole of (A,B) in the first position of the current
  ! active part apC to alpha / beta.
  ! If compAB is true, the complete pencil is updated based on apT,
  ! if not only the active part apC of the pencil is updated
  ! If compQ is true, the transformation is also applied to
  ! the relevant two columns of Q specified by qcol
  !
  ! ARGUMENTS
  !___________________________________________________________________________
  ! alpha   complex double [IN]
  !           Defines the new first pole: alpha/beta
  ! beta    complex double [IN]
  !           Defines the new first pole: alpha/beta
  ! A       complex double array [INOUT]
  !           Upper Hessenberg matrix A
  ! B       complex double array [INOUT]
  !           Upper Hessenberg matrix B
  ! compAB  boolean [IN]
  !           If true, the equivalences are applied to (A,B). If not,
  !           then only to the current active part
  ! apC     type(tAp) [IN]
  !           Current active part
  ! apT     type(tAp) [IN]
  !           Total part of the pencil the method is acting on
  !           (used when compAB is true)
  ! Q       complex double array [INOUT]
  !           Unitary equivalence matrix Q
  ! compQ   boolean [IN]
  !           If true, the left Schur vectors are updated
  ! qcol    integer [IN]
  !           Start index of the columns of Q that are updated:
  !              qcol, qcol+1
  !___________________________________________________________________________
  ! last edit: July 24, 2018
    integer, intent(in)               ::  qcol
    complex(kind=dp), intent(inout)   ::  A(:,:), B(:,:)
    complex(kind=dp), intent(in)      ::  alpha, beta
    logical, intent(in)               ::  compQ, compAB
    complex(kind=dp), intent(inout)   ::  Q(:,:)
    type(tAp), pointer, intent(in)    ::  apC, apT

    complex(kind=dp)                  :: v(2), s, r
    real(kind=dp)                     :: c
    integer,pointer                   :: cstrt, cstp, tstrt, tstp
    complex(kind=dp), external        :: zdotc

    call tApGet(apC,cstrt,cstp)
    call tApGet(apT,tstrt,tstp)

    ! Compute and normalize the vector of interest
    v = A(cstrt+1:cstrt+2,cstrt+1) * beta - B(cstrt+1:cstrt+2,cstrt+1) * alpha
    s = zdotc(2,v,1,v,1)
    v = v / sqrt(abs(s))

    ! Update pair and equivalence
    if (abs(v(2)) .gt. mp) then
      call z_compute_ct(v(1),v(2),c,s,r)
      if (compAB) then
        call z_apply_ct_l(A(cstrt+1,cstrt+1:tstp),A(cstrt+2,cstrt+1:tstp),c,s)
        call z_apply_ct_l(B(cstrt+1,cstrt+1:tstp),B(cstrt+2,cstrt+1:tstp),c,s)
      else
        call z_apply_ct_l(A(cstrt+1,cstrt+1:cstp),A(cstrt+2,cstrt+1:cstp),c,s)
        call z_apply_ct_l(B(cstrt+1,cstrt+1:cstp),B(cstrt+2,cstrt+1:cstp),c,s)
      endif

      if (compQ) then
        !call z_apply_ct_r(Q(:,qcol),Q(:,qcol+1),dconjg(c),-s) ! Own ct
        call z_apply_ct_r(Q(:,qcol),Q(:,qcol+1),c,-s)
      endif
    end if
  end subroutine

  subroutine z_set_last_pole(alpha, beta, A, B, compAB, apC, apT, &
                             Z, compZ, zcol)
  ! DESCRIPTION
  !___________________________________________________________________________
  ! Sets the pole of (A,B) in the last position of apC to
  ! alpha / beta
  ! If compAB is true, the complete pencil is updated based on apT,
  ! if not only the active part apC is updated
  ! If compZ is true, the ctransformation is also applied to
  ! the columns of Z specified by zcol
  !
  ! ARGUMENTS
  !___________________________________________________________________________
  ! alpha   complex double [IN]
  !           Defines the new last pole: alpha/beta
  ! beta    complex double [IN]
  !           Defines the new last pole: alpha/beta
  ! A       complex double array [INOUT]
  !           Upper Hessenberg matrix A
  ! B       complex double array [INOUT]
  !           Upper Hessenberg matrix B
  ! compAB  boolean [IN]
  !           If true, the equivalences are applied to (A,B). If not,
  !           then only to the active parts
  ! apC     type(tAp) [INOUT]
  !           Current active part
  ! apT     type(tAp) [IN]
  !           Total part of the pencil the method is acting on
  !           (used when compAB is true)
  ! Z       complex double array [INOUT]
  !           Unitary equivalence matrix Z
  ! compZ   boolean [IN]
  !           If true, the right Schur vectors are updated
  ! zcol    integer [IN]
  !           Start index of the columns of Z that are updated:
  !              zcol, zcol+1
  !___________________________________________________________________________
  ! last edit: July 24, 2018
    integer, intent(in)               ::  zcol
    complex(kind=dp), intent(inout)   ::  A(:,:), B(:,:)
    complex(kind=dp), intent(in)      ::  alpha, beta
    logical, intent(in)               ::  compAB, compZ
    complex(kind=dp), intent(inout)   ::  Z(:,:)
    type(tAp), pointer, intent(in)    ::  apC
    type(tAp), pointer, intent(in)    ::  apT

    complex(kind=dp)                  ::  v(2), s, r
    real(kind=dp)                     ::  c
    integer,pointer                   ::  cstrt, cstp, tstrt, tstp
    complex(kind=dp), external        ::  zdotc

    call tApGet(apC,cstrt,cstp)
    call tApGet(apT,tstrt,tstp)

    ! Compute and normalize the vector of interest
    v = A(cstp,cstp-1:cstp) * beta - B(cstp,cstp-1:cstp) * alpha
    s = zdotc(2,v,1,v,1)
    v = v / sqrt(abs(s))

    if (abs(v(2)) > mp) then
      call z_compute_ct(v(2),v(1),c,s,r)
      !c = dconjg(c) ! Own ct
      if (compAB) then
          call z_apply_ct_r(A(tstrt+1:cstp,cstp-1),A(tstrt+1:cstp,cstp),c,s)
          call z_apply_ct_r(B(tstrt+1:cstp,cstp-1),B(tstrt+1:cstp,cstp),c,s)
      else
          call z_apply_ct_r(A(cstrt+1:cstp,cstp-1),A(cstrt+1:cstp,cstp),c,s)
          call z_apply_ct_r(B(cstrt+1:cstp,cstp-1),B(cstrt+1:cstp,cstp),c,s)
      endif

      if (compZ) then
        call z_apply_ct_r(Z(:,zcol),Z(:,zcol+1),c,s)
      end if
    end if
  end subroutine

  subroutine z_set_first_m_poles(alpha,beta,A,B,compAB,apC, apT,&
                                 Q,compQ,qcol,Z,compZ,zcol)
  ! DESCRIPTION
  !___________________________________________________________________________
  !
  ! Sets the first m poles of (A,B) starting at the first position of
  ! the current active part apC to the m poles as specified by the arrays:
  !                    alpha./beta
  ! If compAB is true, the complete pencil is updated based on apT, if not,
  ! only the active part apC of the pencil is updated
  ! If compQ is true, the matrix Q is updated accordingly. If compZ is true,
  ! the matrix Z is updated accordingly
  !
  ! ARGUMENTS
  !___________________________________________________________________________
  ! alpha   complex double array [IN]
  !           Defines the new first pole: alpha/beta
  ! beta    complex double array [IN]
  !           Defines the new first pole: alpha/beta
  !           alpha and beta are expected to be of the same
  !           length and this length m are the number of poles
  !           to be introduced
  ! A       complex double array [INOUT]
  !           Upper Hessenberg matrix A
  ! B       complex double array [INOUT]
  !           Upper Hessenberg matrix B
  ! compAB  boolean [IN]
  !           If true, the equivalences are applied to (A,B). If not,
  !           then only to the active parts
  ! apC     type(tAp) [IN]
  !           Current active part
  ! apT     type(tAp) [IN]
  !           Total part of the pencil the method is acting on
  !           (used when compAB is true)
  ! Q       complex double array [INOUT]
  !           Unitary equivalence matrix Q
  ! compQ   boolean [IN]
  !           If true, the left Schur vectors are updated
  ! qcol    integer [IN]
  !           Start index of the columns of Q that are updated:
  !              qcol, qcol+m+1
  ! Z       complex double array [INOUT]
  !           Unitary equivalence matrix Z
  ! compZ   boolean [IN]
  !           If true, the right Schur vectors are updated
  ! zcol    integer [IN]
  !           Start index of the columns of Z that are updated:
  !              zcol, zcol+m
  !___________________________________________________________________________
  ! last edit: July 24, 2019

    complex(kind=dp), intent(inout)   :: A(:,:), B(:,:), Q(:,:), Z(:,:)
    complex(kind=dp), intent(in)      :: alpha(:), beta(:)
    logical, intent(in)               :: compAB, compQ, compZ
    type(tAp), pointer, intent(in)    :: apC, apT
    integer, intent(in)               :: qcol, zcol

    integer                           :: m, i, j, LDAB, LDQ, LDQM, LDZ, &
                                         LDZM, LDC, LDR
    integer,pointer                   :: cstrt, cstp, tstrt, tstp
    type(tAp), pointer                :: apCI, apTI

    external ZGEMM

    call tApGet(apC,cstrt,cstp)
    call tApGet(apT,tstrt,tstp)

    m = size(alpha) ! TODO`

    call z_getLeadingDim(LDAB,A)
    call z_getLeadingDim(LDQ,Q)
    call z_getLeadingDim(LDQM,QM)
    call z_getLeadingDim(LDZ,Z)
    call z_getLeadingDim(LDZM,ZM)
    call z_getLeadingDim(LDC,CuM)
    call z_getLeadingDim(LDR,RuM)

    ! Initialize internal variables
    call tApInit(apCI,cstrt, cstrt+m)
    call tApInit(apTI,cstrt, cstrt+m)
    QM = czero
    do i=1, m+1
        QM(i,i) = cone
    end do
    ZM = czero
    do i=1, m
        ZM(i,i) = cone
    end do

    do i = m, 1, -1
        ! Change the first pole
        call z_set_first_pole(alpha(i), beta(i), A, B, .true., apCI,apTI, &
                              QM, .true., 1)
        ! Swap it to the correct position
        do j=1,i-1
          call z_swap(cstrt+j+1,cstrt+j, A, B, .true., apCI, apTI, &
                      QM, .true., j+1, ZM, .true.,j)
        end do
    end do

    ! Update the rest of the pencil and Q,Z matrices via BLAS
    if (compAB) then
      ! A row update
      call ZGEMM('C','N',m+1,tstp-cstrt-m,m+1,cone,QM(1,1),LDQM,&
                 A(cstrt+1,cstrt+m+1),LDAB,czero,RuM(1,1),LDR)
      A(cstrt+1:cstrt+m+1,cstrt+m+1:tstp) = RuM(1:m+1,1:tstp-cstrt-m)
      ! B row update
      call ZGEMM('C','N',m+1,tstp-cstrt-m,m+1,cone,QM(1,1),LDQM,&
                 B(cstrt+1,cstrt+m+1),LDAB,czero,RuM(1,1),LDR)
      B(cstrt+1:cstrt+m+1,cstrt+m+1:tstp) = RuM(1:m+1,1:tstp-cstrt-m)
      if (cstrt .gt. 0) then
        ! A column update
        call ZGEMM('N','N',cstrt-tstrt,m,m,cone,A(tstrt+1,cstrt+1),LDAB,&
                   ZM(1,1),LDZM,czero,CuM(1,1),LDC)
        A(tstrt+1:cstrt,cstrt+1:cstrt+m) = CuM(1:cstrt-tstrt,1:m)
        ! B column update
        call ZGEMM('N','N',cstrt-tstrt,m,m,cone,B(tstrt+1,cstrt+1),LDAB,&
                   ZM(1,1),LDZM,czero,CuM(1,1),LDC)
        B(tstrt+1:cstrt,cstrt+1:cstrt+m) = CuM(1:cstrt-tstrt,1:m)
      end if
    else
      ! A row update
      call ZGEMM('C','N',m+1,cstp-cstrt-m,m+1,cone,QM(1,1),LDQM,&
                 A(cstrt+1,cstrt+m+1),LDAB,czero,RuM(1,1),LDR)
      A(cstrt+1:cstrt+m+1,cstrt+m+1:cstp) = RuM(1:m+1,1:cstp-cstrt-m)
      ! B row update
      call ZGEMM('C','N',m+1,cstp-cstrt-m,m+1,cone,QM(1,1),LDQM,&
                 B(cstrt+1,cstrt+m+1),LDAB,czero,RuM(1,1),LDR)
      B(cstrt+1:cstrt+m+1,cstrt+m+1:cstp) = RuM(1:m+1,1:cstp-cstrt-m)
    end if

    if (compQ) then
      call ZGEMM('N','N',LDQ,m+1,m+1,cone,Q(1,qcol),LDQ,&
                 QM(1,1),LDQM,czero,CuM,LDC)
      Q(1:LDQ,qcol:qcol+m) = CuM(1:LDQ,1:m+1)
    end if

    if (compZ) then
      call ZGEMM('N','N',LDZ,m,m,cone,Z(1,zcol),LDZ,ZM(1,1),LDZM,czero,CuM,LDC)
      Z(1:LDZ,zcol:zcol+m-1) = CuM(1:LDZ,1:m)
    end if

    ! Free everything
    call tApFree(apCI)
    call tApFree(apTI)

  end subroutine

  subroutine z_set_last_m_poles(alpha,beta,A,B,compAB,apC,apT,&
                                Q,compQ,qcol,Z,compZ,zcol)
  ! DESCRIPTION
  !___________________________________________________________________________
  !
  ! Sets the last m poles of (A,B) ending at position (stpidx,stpidx-1) to
  ! the m poles as specified by the arrays alpha./beta
  ! If compAB is true, the complete pencil is updated, if not, only the active
  ! part of the pencil is updated
  ! If compQ is true, the matrix Q is updated accordingly. If compZ is true,
  ! the matrix Z is updated accordingly
  !
  ! ARGUMENTS
  !___________________________________________________________________________
  ! alpha   complex double array [IN]
  !           Defines the new last pole: alpha/beta
  ! beta    complex double array [IN]
  !           Defines the new last pole: alpha/beta
  !           alpha and beta are expected to be of the same
  !           length and this length m are the number of poles
  !           to be introduced
  ! A       complex double array [INOUT]
  !           Upper Hessenberg matrix A
  ! B       complex double array [INOUT]
  !           Upper Hessenberg matrix B
  ! compAB  boolean [IN]
  !           If true, the equivalences are applied to (A,B). If not,
  !           then only to the active parts
  ! apC     type(tAp) [IN]
  !           Current active part
  ! apT     type(tAp) [IN]
  !           Total part of the pencil the method is acting on
  !           (used when compAB is true)
  ! Q       complex double array [INOUT]
  !           Unitary equivalence matrix Q
  ! compQ   boolean [IN]
  !           If true, the left Schur vectors are updated
  ! qcol    integer [IN]
  !           Start index of the columns of Q that are updated:
  !              qcol, qcol+m
  ! Z       complex double array [INOUT]
  !           Unitary equivalence matrix Z
  ! compZ   boolean [IN]
  !           If true, the right Schur vectors are updated
  ! zcol    integer [IN]
  !           Start index of the columns of Z that are updated:
  !              zcol, zcol+m-1
  !___________________________________________________________________________
  ! last edit: July 24, 2019
    complex(kind=dp), intent(inout)   :: A(:,:), B(:,:), Q(:,:), Z(:,:)
    complex(kind=dp), intent(in)      :: alpha(:), beta(:)
    logical, intent(in)               :: compAB, compQ, compZ
    type(tAp), pointer, intent(in)    :: apC, apT
    integer, intent(in)               :: qcol, zcol

    integer                           :: m, i, j, LDAB, LDQ, LDQM, LDZ,&
                                         LDZM, LDC, LDR
    integer,pointer                   :: cstrt, cstp, tstrt, tstp
    type(tAp), pointer                :: apCI, apTI

    external ZGEMM

    call tApGet(apC,cstrt,cstp)
    call tApGet(apT,tstrt,tstp)

    m = size(alpha) ! TODO
    call z_getLeadingDim(LDAB,A)
    call z_getLeadingDim(LDQ,Q)
    call z_getLeadingDim(LDQM,QM)
    call z_getLeadingDim(LDZ,Z)
    call z_getLeadingDim(LDZM,ZM)
    call z_getLeadingDim(LDC,CuM)
    call z_getLeadingDim(LDR,RuM)

    call tApInit(apCI,cstp-m, cstp)
    call tApInit(apTI,cstp-m, cstp)
    ! Initialize variables
    QM = czero
    do i=1, m
      QM(i,i) = cone
    end do
    ZM = czero
    do i=1, m+1
      ZM(i,i) = cone
    end do

    do i = m, 1, -1
      ! Change the last pole
      call z_set_last_pole(alpha(i), beta(i), A, B, .false., apCI, apTI,&
                           ZM, .true., m)
      ! Swap it to the correct position
      do j=1,i-1
          call z_swap(cstp-j,cstp-j-1, A, B, .false., apCI, apTI, &
                      QM, .true., m-j, ZM, .true.,m-j)
      end do
    end do

    ! Update the rest of the pencil and Q,Z matrices via BLAS
    if (compAB) then
      ! A column update
      call ZGEMM('N','N',cstp-m-tstrt,m+1,m+1,cone,A(tstrt+1,cstp-m),LDAB,ZM(1,1),LDZM,&
                 czero,CuM(1,1),LDC)
      A(tstrt+1:cstp-m,cstp-m:cstp) = CuM(1:cstp-m-tstrt,1:m+1)
      ! B column update
      call ZGEMM('N','N',cstp-m-tstrt,m+1,m+1,cone,B(tstrt+1,cstp-m),LDAB,ZM(1,1),LDZM,&
                 czero,CuM(1,1),LDC)
      B(tstrt+1:cstp-m,cstp-m:cstp) = CuM(1:cstp-m-tstrt,1:m+1)
      if (cstp .lt. tstp) then
        ! A row update
        call ZGEMM('C','N',m,tstp-cstp,m,cone,QM(1,1),LDQM,A(cstp-m+1,cstp+1),&
                   LDAB,czero,RuM(1,1),LDR)
        A(cstp-m+1:cstp,cstp+1:tstp) = RuM(1:m,1:tstp-cstp)
        ! B row update
        call ZGEMM('C','N',m,tstp-cstp,m,cone,QM(1,1),LDQM,B(cstp-m+1,cstp+1),&
                   LDAB,czero,RuM(1,1),LDR)
        B(cstp-m+1:cstp,cstp+1:tstp) = RuM(1:m,1:tstp-cstp)
      end if
    else
      ! A column update
      call ZGEMM('N','N',cstp-cstrt-m,m+1,m+1,cone,A(cstrt+1,cstp-m),&
                 LDAB,ZM(1,1),LDZM,czero,CuM(1,1),LDC)
      A(cstrt+1:cstp-m,cstp-m:cstp) = CuM(1:cstp-cstrt-m,1:m+1)
      ! B column update
      call ZGEMM('N','N',cstp-cstrt-m,m+1,m+1,cone,B(cstrt+1,cstp-m),&
                 LDAB,ZM(1,1),LDZM,czero,CuM(1,1),LDC)
      B(cstrt+1:cstp-m,cstp-m:cstp) = CuM(1:cstp-cstrt-m,1:m+1)
    end if

    if (compQ) then
      call ZGEMM('N','N',LDQ,m,m,cone,Q(1,qcol),LDQ,QM(1,1),LDQM,czero,CuM,LDC)
      Q(1:LDQ,qcol:qcol+m-1) = CuM(1:LDQ,1:m)
    end if

    if (compZ) then
      call ZGEMM('N','N',LDZ,m+1,m+1,cone,Z(1,zcol),LDZ,ZM(1,1),LDZM,&
                 czero,CuM,LDC)
      Z(1:LDZ,zcol:zcol+m) = CuM(1:LDZ,1:m+1)
    end if

    ! Free everything
    call tApFree(apCI)
    call tApFree(apTI)
  end subroutine
end module


	subroutine LVSTAT (lu,mx,my,a,h,atype,htype,amiss,flag)

c	..Print statistics of one 2-d variable
	implicit none

	integer lu		! Output unit
	integer mx,my		! Array sizes
	real a(mx,my)		! The array
	real h			! The argument
	character*4 atype	! Type of the variable(array)
	character*4 htype	! Type of the level(argument)
	real amiss		! missing value flag of a
	character*(*) flag

	integer i,j
	integer imx,imn,jmx,jmn
	integer knt
	real amx,amn
	real avg,dev,d
	logical first

c	..A practical value for the magnitude of the fraction of a real
c	number.

	real rfrcval
	parameter(rfrcval=1.e-5)

c	..function

	logical spv
	real aspv
	spv(aspv)=abs((aspv-amiss)/amiss).le.rfrcval

	knt=0
	avg=0.
	do j=1,my
	  do i=1,mx
	    if(.not.spv(a(i,j))) then
	      avg=avg+a(i,j)
	      knt=knt+1
	    endif
	  end do
	end do
	avg=avg/max(1,knt)

	dev=0.
	do j=1,my
	  do i=1,mx
	    if(.not.spv(a(i,j))) then
	      d=a(i,j)-avg
	      dev=dev+d*d
	    endif
	  end do
	end do
	dev=sqrt(dev/max(1,knt-1))

	amx=a(1,1)
	amn=a(1,1)
	first=.true.
	do j=1,my
	  do i=1,mx
	    if(.not.spv(a(i,j))) then
	      if(first) then
		imx=i
		imn=i
		jmx=j
		jmn=j
		amx=a(imx,jmx)
		amn=a(imn,jmn)
		first=.false.
	      else
		if(a(i,j).gt.amx) then
		  amx=a(i,j)
		  imx=i
		  jmx=j
		endif
		if(a(i,j).lt.amn) then
		  amn=a(i,j)
		  imn=i
		  jmn=j
		endif
	      endif
	    endif
	  end do
	end do

	if(atype.eq.'RELH') then
	  avg=avg*100.
	  dev=dev*100.
	  amx=amx*100.
	  amn=amn*100.
	endif

	if(htype.eq.'NULL'.or.htype.eq.'SRFC') then
	  if(atype.eq.'HGHT'.or.atype.eq.'STRM') then
	    write(lu,'(2a,i6,i7,a,i6,2(a,i7,a,i3,a,i3,a))')
     &	      flag,':',knt,nint(avg),'+',nint(dev),
     &	      ' mx=',nint(amx),'(',imx,',',jmx,')',
     &	      ' mi=',nint(amn),'(',imn,',',jmn,')'
	  elseif(atype.eq.'PRES'.or.atype.eq.'TEMP'.or.
     &	    atype.eq.'WIND'.or.atype.eq.'%REH'.or.
     &	    atype.eq.'RELH'.or.atype.eq.'MIXR') then
	    write(lu,'(2a,i6,f7.1,a,f6.1,2(a,f7.1,a,i3,a,i3,a))')
     &	      flag,':',knt,avg,'+',dev,
     &	      ' mx=',amx,'(',imx,',',jmx,')',
     &	      ' mi=',amn,'(',imn,',',jmn,')'
	  elseif(atype.eq.'NORM') then
	    write(lu,'(2a,i6,f7.3,a,f6.3,2(a,f7.3,a,i3,a,i3,a))')
     &	      flag,':',knt,avg,'+',dev,
     &	      ' mx=',amx,'(',imx,',',jmx,')',
     &	      ' mi=',amn,'(',imn,',',jmn,')'
	  else
	    write(lu,'(2a,i6,1p,e10.3e1,a,e9.3e1,0p,'//
     &	      '2(a,1p,e10.3e1,0p,a,i3,a,i3,a))')
     &	      flag,':',knt,avg,'+',dev,
     &	      ' mx=',amx,'(',imx,',',jmx,')',
     &	      ' mi=',amn,'(',imn,',',jmn,')'
	  endif

	elseif(htype.eq.'PRES') then
	  if(atype.eq.'HGHT'.or.atype.eq.'STRM') then
	    write(lu,'(2a,i4,a,i6,i7,a,i6,2(a,i7,a,i3,a,i3,a))')
     &	      flag,'(',nint(h),')',knt,nint(avg),'+',nint(dev),
     &	      ' mx=',nint(amx),'(',imx,',',jmx,')',
     &	      ' mi=',nint(amn),'(',imn,',',jmn,')'
	  elseif(atype.eq.'PRES'.or.atype.eq.'TEMP'.or.
     &	    atype.eq.'WIND'.or.atype.eq.'%REH'.or.
     &	    atype.eq.'RELH'.or.atype.eq.'MIXR') then
	    write(lu,'(2a,i4,a,i6,f7.1,a,f6.1,'//
     &	      '2(a,f7.1,a,i3,a,i3,a))')
     &	      flag,'(',nint(h),')',knt,avg,'+',dev,
     &	      ' mx=',amx,'(',imx,',',jmx,')',
     &	      ' mi=',amn,'(',imn,',',jmn,')'
	  elseif(atype.eq.'NORM') then
	    write(lu,'(2a,i4,a,i6,f7.3,a,f6.3,'//
     &	      '2(a,f7.3,a,i3,a,i3,a))')
     &	      flag,'(',nint(h),')',knt,avg,'+',dev,
     &	      ' mx=',amx,'(',imx,',',jmx,')',
     &	      ' mi=',amn,'(',imn,',',jmn,')'
	  else
	    write(lu,'(2a,i4,a,i6,1p,e10.3e1,a,e9.3e1,0p,'//
     &	      '2(a,e10.3e1,a,i3,a,i3,a))')
     &	      flag,'(',nint(h),')',knt,avg,'+',dev,
     &	      ' mx=',amx,'(',imx,',',jmx,')',
     &	      ' mi=',amn,'(',imn,',',jmn,')'
	  endif

	elseif(htype.eq.'HGHT') then
	  if(atype.eq.'HGHT'.or.atype.eq.'STRM') then
	    write(lu,'(2a,i5,a,i6,i7,a,i6,2(a,i7,a,i3,a,i3,a))')
     &	      flag,'(',nint(h),')',knt,nint(avg),'+',nint(dev),
     &	      ' mx=',nint(amx),'(',imx,',',jmx,')',
     &	      ' mi=',nint(amn),'(',imn,',',jmn,')'
	  elseif(atype.eq.'PRES'.or.atype.eq.'TEMP'.or.
     &	    atype.eq.'WIND'.or.atype.eq.'%REH'.or.
     &	    atype.eq.'RELH'.or.atype.eq.'MIXR') then
	    write(lu,'(2a,i5,a,i6,f7.1,a,f6.1,'//
     &	      '2(a,f7.1,a,i3,a,i3,a))')
     &	      flag,'(',nint(h),')',knt,avg,'+',dev,
     &	      ' mx=',amx,'(',imx,',',jmx,')',
     &	      ' mi=',amn,'(',imn,',',jmn,')'
	  elseif(atype.eq.'NORM') then
	    write(lu,'(2a,i5,a,i6,f7.3,a,f6.3,'//
     &	      '2(a,f7.3,a,i3,a,i3,a))')
     &	      flag,'(',nint(h),')',knt,avg,'+',dev,
     &	      ' mx=',amx,'(',imx,',',jmx,')',
     &	      ' mi=',amn,'(',imn,',',jmn,')'
	  else
	    write(lu,'(2a,i5,a,i6,1p,e10.3e1,a,e9.3e1,0p,'//
     &	      '2(a,e10.3e1,a,i3,a,i3,a))')
     &	      flag,'(',nint(h),')',knt,avg,'+',dev,
     &	      ' mx=',amx,'(',imx,',',jmx,')',
     &	      ' mi=',amn,'(',imn,',',jmn,')'
	  endif

	elseif(htype.eq.'TEMP') then
	  if(atype.eq.'HGHT'.or.atype.eq.'STRM') then
	    write(lu,'(2a,f7.2,a,i6,i7,a,i6,2(a,i7,a,i3,a,i3,a))')
     &	      flag,'(',h,')',knt,nint(avg),'+',nint(dev),
     &	      ' mx=',nint(amx),'(',imx,',',jmx,')',
     &	      ' mi=',nint(amn),'(',imn,',',jmn,')'
	  elseif(atype.eq.'PRES'.or.atype.eq.'TEMP'.or.
     &	    atype.eq.'WIND'.or.atype.eq.'%REH'.or.
     &	    atype.eq.'RELH'.or.atype.eq.'MIXR') then
	    write(lu,'(2a,f7.2,a,i6,f7.1,a,f6.1,'//
     &	      '2(a,f7.1,a,i3,a,i3,a))')
     &	      flag,'(',h,')',knt,avg,'+',dev,
     &	      ' mx=',amx,'(',imx,',',jmx,')',
     &	      ' mi=',amn,'(',imn,',',jmn,')'
	  elseif(atype.eq.'NORM') then
	    write(lu,'(2a,f7.2,a,i6,f7.3,a,f6.3,'//
     &	      '2(a,f7.3,a,i3,a,i3,a))')
     &	      flag,'(',h,')',knt,avg,'+',dev,
     &	      ' mx=',amx,'(',imx,',',jmx,')',
     &	      ' mi=',amn,'(',imn,',',jmn,')'
	  else
	    write(lu,'(2a,f7.2,a,i6,1p,e10.3e1,a,e9.3e1,0p,'//
     &	      '2(a,e10.3e1,a,i3,a,i3,a))')
     &	      flag,'(',h,')',knt,avg,'+',dev,
     &	      ' mx=',amx,'(',imx,',',jmx,')',
     &	      ' mi=',amn,'(',imn,',',jmn,')'
	  endif

	else
	  if(atype.eq.'HGHT'.or.atype.eq.'STRM') then
	    write(lu,'(2a,1p,e10.3e1,0p,a,i6,i7,a,i6,'//
     &	      '2(a,i7,a,i3,a,i3,a))')
     &	      flag,'(',h,')',knt,nint(avg),'+',nint(dev),
     &	      ' mx=',nint(amx),'(',imx,',',jmx,')',
     &	      ' mi=',nint(amn),'(',imn,',',jmn,')'
	  elseif(atype.eq.'PRES'.or.atype.eq.'TEMP'.or.
     &	    atype.eq.'WIND'.or.atype.eq.'%REH'.or.
     &	    atype.eq.'RELH'.or.atype.eq.'MIXR') then
	    write(lu,'(2a,1p,e10.3e1,0p,a,i6,f7.1,a,f6.1,'//
     &	      '2(a,f7.1,a,i3,a,i3,a))')
     &	      flag,'(',h,')',knt,avg,'+',dev,
     &	      ' mx=',amx,'(',imx,',',jmx,')',
     &	      ' mi=',amn,'(',imn,',',jmn,')'
	  elseif(atype.eq.'NORM') then
	    write(lu,'(2a,1p,e10.3e1,0p,a,i6,f7.3,a,f6.3,'//
     &	      '2(a,f7.3,a,i3,a,i3,a))')
     &	      flag,'(',h,')',knt,avg,'+',dev,
     &	      ' mx=',amx,'(',imx,',',jmx,')',
     &	      ' mi=',amn,'(',imn,',',jmn,')'
	  else
	    write(lu,'(2a,1p,e10.3e1,0p,a,i6,1p,e10.3e1,a,e9.3e1,0p,'//
     &	      '2(a,e10.3e1,a,i3,a,i3,a))')
     &	      flag,'(',h,')',knt,avg,'+',dev,
     &	      ' mx=',amx,'(',imx,',',jmx,')',
     &	      ' mi=',amn,'(',imn,',',jmn,')'
	  endif

	endif

	end


      SUBROUTINE INVERT (A, NZ, MAXZ, INDEX, ROW, KOL)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C     THIS SUBROUTINE WILL INVERT A MATRIX OF ANY ORDER (LIMITED BY
C       COMPUTER CAPACITY) BY A MODIFIED GAUSS-ELIMINATION METHOD.
C         A = THE INPUT MATRIX AS WELL AS THE OUTPUT MATRIX.
C        NZ = THE ORDER OF MATRIX A.
C      MAXZ = THE MAXIMUM ORDER DIMENSIONED IN THE CALLING PROGRAM.
C             THIS PERMITS THE USER TO INVERT ANY MATRIX FROM A 2 BY 2
C               UP TO A MAXZ BY MAXZ FROM CASE TO CASE.
C     INDEX = 1 IF THE INVERSE IS FOUND.
C           = 2 IF THE INPUT MATRIX IS SINGULAR.
C           = 3 IF MACHINE ERROR OCCURRED. IF PROGRAMMER WISHES TO LOOP
C               BACK FOR ANOTHER TRY, BE SURE TO RESET THE INPUT MATRIX.
C       ROW = TEMPORARY WORK STORAGE.
C       KOL = TEMPORARY WORK STORAGE.
C     MATRIX A IS DUMMY DIMENSIONED. THIS SUBROUTINE REFERS TO IT AS A
C       SINGLE DIMENSIONED VARIABLE BY FINDING THE PROPER SUBSCRIPT.
      DIMENSION  A(2), ROW(2), KOL(2)
      N=NZ
      MAX=MAXZ
      KOL(1)=1
      DO 10 I=2,N
      KOL(I)=KOL(I-1)+1
   10 CONTINUE
      DO 120 K=1,N
      L=N-K+1
      M=KOL(1)
      J=1
      IF(N-K) 190,60,20
   20 AMPY=DABS(A(1))
      DO 40 I=2,L
      IF(AMPY-DABS(A(I))) 30,40,40
   30 J=I
      AMPY=DABS(A(I))
      M=KOL(I)
   40 CONTINUE
      IF(KOL(1)-M) 50,60,50
   50 KOL(J)=KOL(1)
      KOL(1)=M
   60 IF(A(J)) 70,200,70
   70 AMPY=A(J)
      DO 80 I=2,N
      IS=(I-1)*MAX+J
      ROW(I-1)=A(IS)/AMPY
      IC=(I-2)*MAX
      IS=IC+J
      IT=IC+1
      A(IS)=A(IT)
   80 CONTINUE
      ROW(N)=1.0D0/AMPY
      IC=(N-1)*MAX
      IS=IC+J
      IT=IC+1
      A(IS)=A(IT)
      DO 100 I=2,N
      AMPY=A(I)
      DO 90 J=2,N
      IS=(J-2)*MAX+I-1
      IT=(J-1)*MAX+I
      A(IS)=A(IT)-AMPY*ROW(J-1)
   90 CONTINUE
      IS=(N-1)*MAX+I-1
      A(IS)= -AMPY*ROW(N)
  100 CONTINUE
      DO 110 J=1,N
      KOL(J)=KOL(J+1)
      IS=(J-1)*MAX+N
      A(IS)=ROW(J)
  110 CONTINUE
      KOL(N)=M
  120 CONTINUE
      DO 170 K=1,N
      IF(KOL(K)-K) 190,170,130
  130 DO 160 I=K,N
      IF(KOL(I)-K) 190,140,160
  140 DO 150 J=1,N
      IS=(I-1)*MAX+J
      IT=(K-1)*MAX+J
      ROW(1)=A(IS)
      A(IS)=A(IT)
      A(IT)=ROW(1)
  150 CONTINUE
      M=KOL(K)
      KOL(K)=KOL(I)
      KOL(I)=M
      GO TO 170
  160 CONTINUE
      INDEX=3
      GO TO 180
  170 CONTINUE
      INDEX=1
  180 RETURN
  190 INDEX=3
      GO TO 180
  200 INDEX=2
      GO TO 180
      END


!
! CRTM_Utility
!
! Module containing CRTM numerical utility routines.
!
! NOTE: This utility is specifically for use with RTSolution codes.
!       Adapted from package of MOM 1991, ASYMTX adapted from DISORT.
!
!
! CREATION HISTORY:
!       Written by:     Quanhua Liu,    Quanhua.Liu@noaa.gov
!                       Yong Han,       Yong.Han@noaa.gov
!                       Paul van Delst, paul.vandelst@noaa.g
!                       08-Jun-2004
!

MODULE CRTM_UTILITY

  ! -----------------
  ! Environment setup
  ! -----------------
  ! Module use
  USE Type_Kinds     , ONLY: fp
  USE Message_Handler, ONLY: Display_Message, SUCCESS, FAILURE, WARNING
  USE CRTM_Parameters, ONLY: ZERO, ONE, TWO, &
                             POINT_25, POINT_5, &
                             PI
  ! Disable implicit typing
  IMPLICIT NONE

  ! ------------
  ! Visibilities
  ! ------------
  PRIVATE
  PUBLIC :: matinv
  PUBLIC :: DOUBLE_GAUSS_QUADRATURE
  PUBLIC :: Legendre
  PUBLIC :: Legendre_M
  PUBLIC :: ASYMTX,ASYMTX_TL,ASYMTX_AD
  PUBLIC :: ASYMTX2_AD

  ! -------------------
  ! Procedure overloads
  ! -------------------
  INTERFACE Legendre
    MODULE PROCEDURE Legendre_scalar
    MODULE PROCEDURE Legendre_rank1
  END INTERFACE

  ! -----------------
  ! Module parameters
  ! -----------------
  ! Numerical small threshold value in Eigensystem
  REAL(fp), PARAMETER :: EIGEN_THRESHOLD = 1.0e-20_fp

CONTAINS

  SUBROUTINE DOUBLE_GAUSS_QUADRATURE(NUM, ABSCISSAS, WEIGHTS)
    ! Generates the abscissas and weights for an even 2*NUM point
    ! Gauss-Legendre quadrature.  Only the NUM positive points are returned.
    IMPLICIT NONE
    INTEGER, INTENT(IN) ::  NUM
    REAL( fp), DIMENSION(:) ::   ABSCISSAS, WEIGHTS
    INTEGER  N, K, I, J, L
    REAL(fp) ::   X, XP, PL, PL1, PL2, DPL
    ! REAL(fp), PARAMETER :: TINY1=3.0E-14_fp
    REAL(fp) :: TINY1
    PARAMETER(TINY1=3.0D-14)
    N = NUM
    K = (N+1)/2
    DO J = 1, K
      X = COS(PI*(J-POINT_25)/(N+POINT_5))
      I = 0
    100  CONTINUE
      PL1 = 1
      PL = X
      DO L = 2, N
        PL2 = PL1
        PL1 = PL
        PL = ( (2*L-1)*X*PL1 - (L-1)*PL2 )/L
      END DO
      DPL = N*(X*PL-PL1)/(X*X-1)
      XP = X
      X = XP - PL/DPL
      I = I+1
      IF (ABS(X-XP).GT.TINY1 .AND. I.LT.10) GO TO 100
        ABSCISSAS(J) = (ONE-X)/TWO
        ABSCISSAS(NUM+1-J) = (ONE+X)/TWO
        WEIGHTS(NUM+1-J) = ONE/((ONE-X*X)*DPL*DPL)
        WEIGHTS(J)       = ONE/((ONE-X*X)*DPL*DPL)
    END DO
    RETURN
  END SUBROUTINE DOUBLE_GAUSS_QUADRATURE
!
!
  FUNCTION matinv(A, Error_Status)
    ! --------------------------------------------------------------------
    ! Compute the inversion of the matrix A
    ! Invert matrix by Gauss method
    ! --------------------------------------------------------------------
    IMPLICIT NONE
    REAL(fp), intent(in),dimension(:,:) :: a
    INTEGER, INTENT( OUT ) :: Error_Status

    INTEGER:: n
    REAL(fp), dimension(size(a,1),size(a,2)) :: b
    REAL(fp ), dimension(size(a,1),size(a,2)) :: matinv
    REAL(fp), dimension(size(a,1)) :: temp
    ! Local parameters
    CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'matinv'
    ! - - - Local Variables - - -
    REAL(fp) :: c, d
    INTEGER :: i, j, k, m, imax(1), ipvt(size(a,1))
    ! - - - - - - - - - - - - - -
    Error_Status = SUCCESS
    b = a
    n=size(a,1)
    matinv=a
    ipvt = (/ (i, i = 1, n) /)
    ! Go into loop- b, the inverse, is initialized equal to a above
    DO k = 1,n
    ! Find the largest value and position of that value
      imax = MAXLOC(ABS(b(k:n,k)))
      m = k-1+imax(1)
    ! sigular matrix check
      IF ( ABS(b(m,k)).LE.(1.E-40_fp) ) THEN
        Error_Status = FAILURE
        CALL Display_Message( ROUTINE_NAME, 'Singular matrix', Error_Status )
        RETURN
      END IF
    ! get the row beneath the current row if the current row will
    ! not compute
      IF ( m .ne. k ) THEN
        ipvt( (/m,k/) ) = ipvt( (/k,m/) )
        b((/m,k/),:) = b((/k,m/),:)
      END IF
    ! d is a coefficient - brings the pivot value to one and then is applied
    ! to the rest of the row
      d = 1/b(k,k)
      temp = b(:,k)
      DO j = 1, n
         c = b(k,j)*d
         b(:,j) = b(:,j)-temp*c
         b(k,j) = c
      END DO
      b(:,k) = temp*(-d)
      b(k,k) = d
    END DO
    matinv(:,ipvt) = b
  END FUNCTION matinv
!
!
  SUBROUTINE Legendre_Scalar(MOA,ANG,PL)
    !  calculating Legendre polynomial using recurrence relationship
    IMPLICIT NONE
    INTEGER, INTENT(in) :: MOA
    REAL(fp), intent(in) :: ANG
    REAL(fp), intent(out), dimension(0:MOA):: PL
    INTEGER :: j
    PL(0)=ONE
    PL(1)=ANG
    IF ( MOA.GE.2 ) THEN
      DO J = 1, MOA -1
        PL(J+1)=REAL(2*J+1,fp)/REAL(J+1,fp)*ANG*PL(J) &
          -REAL(J,fp)/REAL(J+1,fp)*PL(J-1)
      END DO
    END IF
    RETURN
  END SUBROUTINE Legendre_Scalar
!
!
   SUBROUTINE Legendre_Rank1(MOA,NU,ANG,PL)
     !  calculating Legendre polynomial using recurrence relationship
     IMPLICIT NONE
     INTEGER, intent(in):: MOA,NU
     REAL(fp), INTENT(in), dimension(NU):: ANG
     REAL(fp), INTENT(out),dimension(0:MOA,NU):: PL
     REAL(fp) :: TE
     INTEGER :: i,j
     DO i = 1,NU
       TE=ANG(i)
       PL(0,i)=ONE
       PL(1,i)=TE
       IF(MOA.GE.2) THEN
         DO J = 1, MOA-1
           PL(J+1,i)=REAL(2*J+1, fp)/REAL(J+1, fp)*TE*PL(J,i) &
           -REAL(J, fp)/REAL(J+1, fp)*PL(J-1,i)
         END DO
       END IF
     END DO
     RETURN
   END SUBROUTINE Legendre_Rank1
!
!
   SUBROUTINE Legendre_M(MF,N,U,PL)
     IMPLICIT NONE
     REAL(fp), INTENT(IN) :: U
     INTEGER, INTENT(IN) :: N,MF
     REAL(fp), DIMENSION(0:N) :: PL
     REAL(fp) :: f
     INTEGER:: J
     IF ( MF.GT.N ) THEN
       PL = 0.0_fp
     ELSE
       IF ( MF .EQ. 0 ) THEN
         f = 1.0_fp
         PL(0) = 1.0_fp
       ELSE
         f=sqrt(gamma2(2*MF))/gamma2(MF)/(2**MF)
         PL(MF)=f*sqrt((1.0_fp-U*U)**MF)
       END IF
       IF ( N.GT.MF )  PL(MF+1)=U*sqrt(2*MF+1.0_fp)*PL(MF)
       IF( N.gt.(MF+1) ) THEN
         DO J=MF+1,N-1
           PL(J+1)=(FLOAT(2*J+1)*U*PL(J) &
           -sqrt(FLOAT(J*J-MF*MF))*PL(J-1))/sqrt(float((J+1)**2-MF*MF))
         END DO
       END IF
     END IF
   END SUBROUTINE Legendre_M
!
!
   FUNCTION gamma2(N)
     ! Compute gamma function value
     IMPLICIT NONE
     INTEGER, INTENT(IN) :: N
     INTEGER :: i
     REAL(fp) :: gamma2

     IF ( N.lt.0 ) THEN
       CALL Display_Message('gamma2','Invalid input', WARNING)
       gamma2 = 1.0_fp
     ELSE
       gamma2=1.0_fp
       IF( N.gt.0 ) THEN
         DO i = 1 , N
         gamma2=gamma2*float(i)
         END DO
        END IF
     END IF
   END FUNCTION gamma2
!
!
   SUBROUTINE  ASYMTX( AAD, M, IA, IEVEC, &
                            EVECD, EVALD, IER)

!    =======  D O U B L E    P R E C I S I O N    V E R S I O N  ======

!       Solves eigenfunction problem for real asymmetric matrix
!       for which it is known a priori that the eigenvalues are real.

!       This is an adaptation of a subroutine EIGRF in the IMSL
!       library to use real instead of complex arithmetic, accounting
!       for the known fact that the eigenvalues and eigenvectors in
!       the discrete ordinate solution are real.  Other changes include
!       putting all the called subroutines in-line, deleting the
!       performance index calculation, updating many DO-loops
!       to Fortran77, and in calculating the machine precision
!       TOL instead of specifying it in a data statement.

!       EIGRF is based primarily on EISPACK routines.  The matrix is
!       first balanced using the parlett-reinsch algorithm.  Then
!       the Martin-Wilkinson algorithm is applied.

!       References:
!          Dongarra, J. and C. Moler, EISPACK -- A Package for Solving
!             Matrix Eigenvalue Problems, in Cowell, ed., 1984:
!             Sources and Development of Mathematical Software,
!             Prentice-Hall, Englewood Cliffs, NJ
!         Parlett and Reinsch, 1969: Balancing a Matrix for Calculation
!             of Eigenvalues and Eigenvectors, Num. Math. 13, 293-304
!         Wilkinson, J., 1965: The Algebraic Eigenvalue Problem,
!             Clarendon Press, Oxford

!   I N P U T    V A R I A B L E S:

!        AAD  :  input asymmetric matrix, destroyed after solved
!        M    :  order of  A
!       IA    :  first dimension of  A
!    IEVEC    :  first dimension of  EVECD

!   O U T P U T    V A R I A B L E S:

!       EVECD :  (unnormalized) eigenvectors of  A
!                   ( column J corresponds to EVALD(J) )

!       EVALD :  (unordered) eigenvalues of  A ( dimension at least M )

!       IER   :  if .NE. 0, signals that EVALD(IER) failed to converge;
!                   in that case eigenvalues IER+1,IER+2,...,M  are
!                   correct but eigenvalues 1,...,IER are set to zero.
      IMPLICIT NONE
      LOGICAL            BAD_STATUS
      CHARACTER(len=200) :: MESSAGE

!   S C R A T C H   V A R I A B L E S:

!       WKD    :  WORK AREA ( DIMENSION AT LEAST 2*M )
!+---------------------------------------------------------------------+

!  include file for dimensioning

!!      INCLUDE '../includes/VLIDORT.PARS'

!  input/output arguments

      INTEGER :: M, IA, IEVEC, IER
      INTEGER, PARAMETER :: MAXSTRMSTKS = 30
      REAL( fp), PARAMETER :: C1=0.4375_fp,C2=0.5_fp,C3=0.75_fp,C4=0.95_fp,C5=16.0_fp,C6=256.0_fp
      REAL( fp), DIMENSION(:,:) :: AAD, EVECD
      REAL( fp), DIMENSION(:) :: EVALD
      REAL( fp) :: WKD(4*MAXSTRMSTKS), nor_factor

!  local variables (explicit declaration

      LOGICAL           NOCONV, NOTLAS
      INTEGER :: I, J, L, K, KKK, LLL,N, N1, N2, IN, LB, KA, II
!      DOUBLE PRECISION  TOL, DISCRI, SGN, RNORM, W, F, G, H, P, Q, R
      REAL(fp) :: TOL, DISCRI, SGN, RNORM, W, F, G, H, P, Q, R
      REAL(fp) :: REPL, COL, ROW, SCALE, T, X, Z, S, Y, UU, VV
!
      IER = 0
      BAD_STATUS = .FALSE.
      MESSAGE = ' '

!       Here change to bypass D1MACH:
      TOL = 1.0D-12
!        TOL = D1MACH(4)
      IF ( M.LT.1 .OR. IA.LT.M .OR. IEVEC.LT.M ) THEN
        MESSAGE = 'ASYMTX--bad input variable(s)'
        BAD_STATUS = .TRUE.
        RETURN
      ENDIF
!                           ** HANDLE 1X1 AND 2X2 SPECIAL CASES
      IF ( M.EQ.1 )  THEN
         EVALD(1) = AAD(1,1)
         EVECD(1,1) = 1.0D0
         RETURN
      ELSE IF ( M.EQ.2 )  THEN
         DISCRI = ( AAD(1,1) - AAD(2,2) )**2 + 4.0D0*AAD(1,2)*AAD(2,1)
         IF ( DISCRI.LT.ZERO ) THEN
           MESSAGE = 'ASYMTX--COMPLEX EVALS IN 2X2 CASE'
           BAD_STATUS = .TRUE.
           RETURN
         ENDIF
         SGN = ONE
         IF ( AAD(1,1).LT.AAD(2,2) )  SGN = - ONE
         EVALD(1) = 0.5D0*( AAD(1,1) + AAD(2,2) + SGN*SQRT(DISCRI) )
         EVALD(2) = 0.5D0*( AAD(1,1) + AAD(2,2) - SGN*SQRT(DISCRI) )
         EVECD(1,1) = ONE
         EVECD(2,2) = ONE
         IF ( AAD(1,1).EQ.AAD(2,2) .AND. &
               (AAD(2,1).EQ.ZERO.OR.AAD(1,2).EQ.ZERO) ) THEN
            RNORM = ABS(AAD(1,1))+ABS(AAD(1,2))+ &
                      ABS(AAD(2,1))+ABS(AAD(2,2))
            W = TOL * RNORM
            EVECD(2,1) = AAD(2,1) / W
            EVECD(1,2) = - AAD(1,2) / W
         ELSE
            EVECD(2,1) = AAD(2,1) / ( EVALD(1) - AAD(2,2) )
            EVECD(1,2) = AAD(1,2) / ( EVALD(2) - AAD(1,1) )
         ENDIF
         RETURN
      END IF
!                                        ** INITIALIZE OUTPUT VARIABLES
      DO 20 I = 1, M
         EVALD(I) = ZERO
         DO 10 J = 1, M
            EVECD(I,J) = ZERO
10       CONTINUE
         EVECD(I,I) = ONE
20    CONTINUE
!                  ** BALANCE THE INPUT MATRIX AND REDUCE ITS NORM BY
!                  ** DIAGONAL SIMILARITY TRANSFORMATION STORED IN WK;
!                  ** THEN SEARCH FOR ROWS ISOLATING AN EIGENVALUE
!                  ** AND PUSH THEM DOWN
      RNORM = ZERO
      L  = 1
      K  = M

30    KKK = K
         DO 70  J = KKK, 1, -1
            ROW = ZERO
            DO 40 I = 1, K
               IF ( I.NE.J ) ROW = ROW + ABS( AAD(J,I) )
40          CONTINUE
            IF ( ROW.EQ.ZERO ) THEN
               WKD(K) = J
               IF ( J.NE.K ) THEN
                  DO 50 I = 1, K
                     REPL   = AAD(I,J)
                     AAD(I,J) = AAD(I,K)
                     AAD(I,K) = REPL
50                CONTINUE
                  DO 60 I = L, M
                     REPL   = AAD(J,I)
                     AAD(J,I) = AAD(K,I)
                     AAD(K,I) = REPL
60                CONTINUE
               END IF
               K = K - 1
               GO TO 30
            END IF
70       CONTINUE
!                                     ** SEARCH FOR COLUMNS ISOLATING AN
!                                       ** EIGENVALUE AND PUSH THEM LEFT
80    LLL = L
         DO 120 J = LLL, K
            COL = ZERO
            DO 90 I = L, K
               IF ( I.NE.J ) COL = COL + ABS( AAD(I,J) )
90          CONTINUE
            IF ( COL.EQ.ZERO ) THEN
               WKD(L) = J
               IF ( J.NE.L ) THEN
                  DO 100 I = 1, K
                     REPL   = AAD(I,J)
                     AAD(I,J) = AAD(I,L)
                     AAD(I,L) = REPL
100               CONTINUE
                  DO 110 I = L, M
                     REPL   = AAD(J,I)
                     AAD(J,I) = AAD(L,I)
                     AAD(L,I) = REPL
110               CONTINUE
               END IF
               L = L + 1
               GO TO 80
            END IF
120      CONTINUE
!                           ** BALANCE THE SUBMATRIX IN ROWS L THROUGH K
      DO 130 I = L, K
         WKD(I) = ONE
130   CONTINUE

140   NOCONV = .FALSE.
         DO 200 I = L, K
            COL = ZERO
            ROW = ZERO
            DO 150 J = L, K
               IF ( J.NE.I ) THEN
                  COL = COL + ABS( AAD(J,I) )
                  ROW = ROW + ABS( AAD(I,J) )
               END IF
150         CONTINUE
            F = ONE
            G = ROW / C5
            H = COL + ROW
160         IF ( COL.LT.G ) THEN
               F   = F * C5
               COL = COL * C6
               GO TO 160
            END IF
            G = ROW * C5
170         IF ( COL.GE.G ) THEN
               F   = F / C5
               COL = COL / C6
               GO TO 170
            END IF
!                                                         ** NOW BALANCE
            IF ( (COL+ROW)/F .LT. C4*H ) THEN
               WKD(I)  = WKD(I) * F
               NOCONV = .TRUE.
               DO 180 J = L, M
                  AAD(I,J) = AAD(I,J) / F
180            CONTINUE
               DO 190 J = 1, K
                  AAD(J,I) = AAD(J,I) * F
190            CONTINUE
            END IF
200      CONTINUE

      IF ( NOCONV ) GO TO 140
!                                  ** IS -A- ALREADY IN HESSENBERG FORM?
      IF ( K-1 .LT. L+1 ) GO TO 350
!                                   ** TRANSFER -A- TO A HESSENBERG FORM
      DO 290 N = L+1, K-1
         H        = ZERO
         WKD(N+M) = ZERO
         SCALE    = ZERO
!                                                        ** SCALE COLUMN
         DO 210 I = N, K
            SCALE = SCALE + ABS(AAD(I,N-1))
210      CONTINUE
         IF ( SCALE.NE.ZERO ) THEN
            DO 220 I = K, N, -1
               WKD(I+M) = AAD(I,N-1) / SCALE
               H = H + WKD(I+M)**2
220         CONTINUE
            G = - SIGN( SQRT(H), WKD(N+M) )
            H = H - WKD(N+M) * G
            WKD(N+M) = WKD(N+M) - G
!                                                 ** FORM (I-(U*UT)/H)*A
            DO 250 J = N, M
               F = ZERO
               DO 230  I = K, N, -1
                  F = F + WKD(I+M) * AAD(I,J)
230            CONTINUE
               DO 240 I = N, K
                  AAD(I,J) = AAD(I,J) - WKD(I+M) * F / H
240            CONTINUE
250         CONTINUE
!                                    ** FORM (I-(U*UT)/H)*A*(I-(U*UT)/H)
            DO 280 I = 1, K
               F = ZERO
               DO 260  J = K, N, -1
                  F = F + WKD(J+M) * AAD(I,J)
260            CONTINUE
               DO 270 J = N, K
                  AAD(I,J) = AAD(I,J) - WKD(J+M) * F / H
270            CONTINUE
280         CONTINUE
            WKD(N+M)  = SCALE * WKD(N+M)
            AAD(N,N-1) = SCALE * G
         END IF
290   CONTINUE

      DO 340  N = K-2, L, -1
         N1 = N + 1
         N2 = N + 2
         F  = AAD(N1,N)
         IF ( F.NE.ZERO ) THEN
            F  = F * WKD(N1+M)
            DO 300 I = N2, K
               WKD(I+M) = AAD(I,N)
300         CONTINUE
            IF ( N1.LE.K ) THEN
               DO 330 J = 1, M
                  G = ZERO
                  DO 310 I = N1, K
                     G = G + WKD(I+M) * EVECD(I,J)
310               CONTINUE
                  G = G / F
                  DO 320 I = N1, K
                     EVECD(I,J) = EVECD(I,J) + G * WKD(I+M)
320               CONTINUE
330            CONTINUE
            END IF
         END IF
340   CONTINUE

350   CONTINUE
      N = 1
      DO 370 I = 1, M
         DO 360 J = N, M
            RNORM = RNORM + ABS(AAD(I,J))
360      CONTINUE
         N = I
         IF ( I.LT.L .OR. I.GT.K ) EVALD(I) = AAD(I,I)
370   CONTINUE
      N = K
      T = ZERO
!                                         ** SEARCH FOR NEXT EIGENVALUES
380   IF ( N.LT.L ) GO TO 530
      IN = 0
      N1 = N - 1
      N2 = N - 2
!                          ** LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
390   CONTINUE
      DO 400 I = L, N
         LB = N+L - I
         IF ( LB.EQ.L ) GO TO 410
         S = ABS( AAD(LB-1,LB-1) ) + ABS( AAD(LB,LB) )
         IF ( S.EQ.ZERO ) S = RNORM
         IF ( ABS(AAD(LB,LB-1)) .LE. TOL*S ) GO TO 410
400   CONTINUE

410   X = AAD(N,N)
      IF ( LB.EQ.N ) THEN
!                                        ** ONE EIGENVALUE FOUND
         AAD(N,N)  = X + T
         EVALD(N) = AAD(N,N)
         N = N1
         GO TO 380
      END IF

      Y = AAD(N1,N1)
      W = AAD(N,N1) * AAD(N1,N)
      IF ( LB.EQ.N1 ) THEN
!                                        ** TWO EIGENVALUES FOUND
         P = (Y-X) * C2
         Q = P**2 + W
         Z = SQRT( ABS(Q) )
         AAD(N,N) = X + T
         X = AAD(N,N)
         AAD(N1,N1) = Y + T
!                                        ** REAL PAIR
         Z = P + SIGN(Z,P)
         EVALD(N1) = X + Z
         EVALD(N)  = EVALD(N1)
         IF ( Z.NE.ZERO ) EVALD(N) = X - W / Z
         X = AAD(N,N1)
!                                  ** EMPLOY SCALE FACTOR IN CASE
!                                  ** X AND Z ARE VERY SMALL
         R = SQRT( X*X + Z*Z )
         P = X / R
         Q = Z / R
!                                             ** ROW MODIFICATION
         DO 420 J = N1, M
            Z = AAD(N1,J)
            AAD(N1,J) = Q * Z + P * AAD(N,J)
            AAD(N,J)  = Q * AAD(N,J) - P * Z
420      CONTINUE
!                                             ** COLUMN MODIFICATION
         DO 430 I = 1, N
            Z = AAD(I,N1)
            AAD(I,N1) = Q * Z + P * AAD(I,N)
            AAD(I,N)  = Q * AAD(I,N) - P * Z
430      CONTINUE
!                                          ** ACCUMULATE TRANSFORMATIONS
         DO 440 I = L, K
            Z = EVECD(I,N1)
            EVECD(I,N1) = Q * Z + P * EVECD(I,N)
            EVECD(I,N)  = Q * EVECD(I,N) - P * Z
440      CONTINUE

         N = N2
         GO TO 380
      END IF

      IF ( IN.EQ.30 ) THEN
!                    ** NO CONVERGENCE AFTER 30 ITERATIONS; SET ERROR
!                    ** INDICATOR TO THE INDEX OF THE CURRENT EIGENVALUE
         IER = N
         GO TO 670
      END IF
!                                                          ** FORM SHIFT
      IF ( IN.EQ.10 .OR. IN.EQ.20 ) THEN
         T = T + X
         DO 450 I = L, N
            AAD(I,I) = AAD(I,I) - X
450      CONTINUE
         S = ABS(AAD(N,N1)) + ABS(AAD(N1,N2))
         X = C3 * S
         Y = X
         W = - C1 * S**2
      END IF

      IN = IN + 1
!                ** LOOK FOR TWO CONSECUTIVE SMALL SUB-DIAGONAL ELEMENTS

      DO 460 J = LB, N2
         I = N2+LB - J
         Z = AAD(I,I)
         R = X - Z
         S = Y - Z
         P = ( R * S - W ) / AAD(I+1,I) + AAD(I,I+1)
         Q = AAD(I+1,I+1) - Z - R - S
         R = AAD(I+2,I+1)
         S = ABS(P) + ABS(Q) + ABS(R)
         P = P / S
         Q = Q / S
         R = R / S
         IF ( I.EQ.LB ) GO TO 470
         UU = ABS( AAD(I,I-1) ) * ( ABS(Q) + ABS(R) )
         VV = ABS(P)*(ABS(AAD(I-1,I-1))+ABS(Z)+ABS(AAD(I+1,I+1)))
         IF ( UU .LE. TOL*VV ) GO TO 470
460   CONTINUE

470   CONTINUE
      AAD(I+2,I) = ZERO
      DO 480 J = I+3, N
         AAD(J,J-2) = ZERO
         AAD(J,J-3) = ZERO
480   CONTINUE

!             ** DOUBLE QR STEP INVOLVING ROWS K TO N AND COLUMNS M TO N

      DO 520 KA = I, N1
         NOTLAS = KA.NE.N1
         IF ( KA.EQ.I ) THEN
            S = SIGN( SQRT( P*P + Q*Q + R*R ), P )
            IF ( LB.NE.I ) AAD(KA,KA-1) = - AAD(KA,KA-1)
         ELSE
            P = AAD(KA,KA-1)
            Q = AAD(KA+1,KA-1)
            R = ZERO
            IF ( NOTLAS ) R = AAD(KA+2,KA-1)
            X = ABS(P) + ABS(Q) + ABS(R)
            IF ( X.EQ.ZERO ) GO TO 520
            P = P / X
            Q = Q / X
            R = R / X
            S = SIGN( SQRT( P*P + Q*Q + R*R ), P )
            AAD(KA,KA-1) = - S * X
         END IF
         P = P + S
         X = P / S
         Y = Q / S
         Z = R / S
         Q = Q / P
         R = R / P
!                                                    ** ROW MODIFICATION
         DO 490 J = KA, M
            P = AAD(KA,J) + Q * AAD(KA+1,J)
            IF ( NOTLAS ) THEN
               P = P + R * AAD(KA+2,J)
               AAD(KA+2,J) = AAD(KA+2,J) - P * Z
            END IF
            AAD(KA+1,J) = AAD(KA+1,J) - P * Y
            AAD(KA,J)   = AAD(KA,J)   - P * X
490      CONTINUE
!                                                 ** COLUMN MODIFICATION
         DO 500 II = 1, MIN0(N,KA+3)
            P = X * AAD(II,KA) + Y * AAD(II,KA+1)
            IF ( NOTLAS ) THEN
               P = P + Z * AAD(II,KA+2)
               AAD(II,KA+2) = AAD(II,KA+2) - P * R
            END IF
            AAD(II,KA+1) = AAD(II,KA+1) - P * Q
            AAD(II,KA)   = AAD(II,KA) - P
500      CONTINUE
!                                          ** ACCUMULATE TRANSFORMATIONS
         DO 510 II = L, K
            P = X * EVECD(II,KA) + Y * EVECD(II,KA+1)
            IF ( NOTLAS ) THEN
               P = P + Z * EVECD(II,KA+2)
               EVECD(II,KA+2) = EVECD(II,KA+2) - P * R
            END IF
            EVECD(II,KA+1) = EVECD(II,KA+1) - P * Q
            EVECD(II,KA)   = EVECD(II,KA) - P
510      CONTINUE

520   CONTINUE
      GO TO 390
!                     ** ALL EVALS FOUND, NOW BACKSUBSTITUTE REAL VECTOR
530   CONTINUE
      IF ( RNORM.NE.ZERO ) THEN
         DO 560  N = M, 1, -1
            N2 = N
            AAD(N,N) = ONE
            DO 550  I = N-1, 1, -1
               W = AAD(I,I) - EVALD(N)
               IF ( W.EQ.ZERO ) W = TOL * RNORM
               R = AAD(I,N)
               DO 540 J = N2, N-1
                  R = R + AAD(I,J) * AAD(J,N)
540            CONTINUE
               AAD(I,N) = - R / W
               N2 = I
550         CONTINUE
560      CONTINUE
!                      ** END BACKSUBSTITUTION VECTORS OF ISOLATED EVALS

         DO 580 I = 1, M
            IF ( I.LT.L .OR. I.GT.K ) THEN
               DO 570 J = I, M
                  EVECD(I,J) = AAD(I,J)
570            CONTINUE
            END IF
580      CONTINUE
!                                   ** MULTIPLY BY TRANSFORMATION MATRIX
         IF ( K.NE.0 ) THEN
            DO J = M, L, -1
               DO I = L, K
                  Z = ZERO
                  DO 590 N = L, MIN0(J,K)
                     Z = Z + EVECD(I,N) * AAD(N,J)
590               CONTINUE
                  EVECD(I,J) = Z
               END DO
            END DO
         END IF

      END IF

      DO I = L, K
         DO J = 1, M
            EVECD(I,J) = EVECD(I,J) * WKD(I)
         END DO
      END DO
!                           ** INTERCHANGE ROWS IF PERMUTATIONS OCCURRED
      DO 640  I = L-1, 1, -1
         J = INT(WKD(I))
         IF ( I.NE.J ) THEN
            DO 630 N = 1, M
               REPL       = EVECD(I,N)
               EVECD(I,N) = EVECD(J,N)
               EVECD(J,N) = REPL
630         CONTINUE
         END IF
640   CONTINUE

      DO 660 I = K+1, M
         J = INT(WKD(I))
         IF ( I.NE.J ) THEN
            DO 650 N = 1, M
               REPL       = EVECD(I,N)
               EVECD(I,N) = EVECD(J,N)
               EVECD(J,N) = REPL
650         CONTINUE
         END IF
660   CONTINUE
!
  670 CONTINUE
!
!  normalizing eigenvector
      DO j = 1, M
        nor_factor = ZERO
        DO i = 1, M
        nor_factor = nor_factor + EVECD(I,J)**2
        END DO
        nor_factor = sqrt(nor_factor)
        EVECD(:,j) = EVECD(:,j)/nor_factor
      END DO
      RETURN
   END SUBROUTINE  ASYMTX
!
!
     SUBROUTINE ASYMTX_TL( nZ, V, VAL, A_TL, V_TL, VAL_TL, Error_Status)
       IMPLICIT NONE
       INTEGER :: nZ,Error_Status
       REAL(fp), DIMENSION(:,:) :: V, A_TL, V_TL
       REAL(fp), DIMENSION(:) :: VAL, VAL_TL
       REAL(fp), DIMENSION(nZ,nZ) :: V_int, A1_TL
       REAL(fp) :: b_TL
       INTEGER :: i,j
       CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'ASYMTX_TL'
       CHARACTER(256) :: Message
     !
       V_int = matinv( V(1:nZ,1:nZ), Error_Status )
       IF( Error_Status /= SUCCESS  ) THEN
         WRITE( Message,'("Error in matrix inversion matinv( V(1:nZ,1:nZ), Error_Status ) ")' )
         CALL Display_Message( ROUTINE_NAME, &
                               TRIM(Message), &
                               Error_Status )
         RETURN
       END IF
       ! part 1
       !!  A1_TL = ZERO
       A1_TL = matmul( V_int, matmul(A_TL, V) )

       ! part 2
       !!  A1_TL = ZERO
       !!  V_TL = ZERO
       DO i = 1, nZ
         VAL_TL(i) = A1_TL(i,i)
         DO j = 1, nZ
          IF( i /= j ) THEN
            if( abs(VAL(j)-VAL(i)) > EIGEN_THRESHOLD ) then
              V_TL(i,j) = A1_TL(i,j)/(VAL(j)-VAL(i))
            else
              V_TL(i,j) = ZERO
            end if
          ELSE
            V_TL(i,j) = ZERO
          END IF
         END DO
       END DO

       ! part 3
       !!  A1_TL = ZERO
       A1_TL = matmul( V, V_TL)
       !!  V_TL = ZERO
       ! part 4
       DO i = 1, nZ
         b_TL = ZERO
         DO j = 1, nZ
           b_TL = b_TL - V(j,i)*A1_TL(j,i)
         END DO
!
         DO j = 1, nZ
           V_TL(j,i) = A1_TL(j,i) + V(j,i)*b_TL
         END DO
       END DO

       RETURN
       END SUBROUTINE ASYMTX_TL
!
!
     SUBROUTINE ASYMTX_AD( nZ, V, VAL, V_AD, VAL_AD, A_AD, Error_Status)
       IMPLICIT NONE
       INTEGER :: nZ,Error_Status
       REAL(fp), DIMENSION(:,:) :: V, V_AD, A_AD
       REAL(fp), DIMENSION(:) :: VAL, VAL_AD
       INTEGER :: i,j,k
       REAL(fp), DIMENSION(nZ,nZ) :: V_int, A1_AD
       CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'ASYMTX_AD'
       CHARACTER(256) :: Message
     !
       A1_AD = ZERO
       DO i = 1, nZ
         DO j = 1, nZ
         DO k = 1, nZ
          IF( k /= j ) THEN
            if( abs(VAL(j)-VAL(k)) > EIGEN_THRESHOLD ) &
             A1_AD(k,j) = A1_AD(k,j) + V(i,k)*V_AD(i,j)/(VAL(j)-VAL(k))
          END IF
         END DO
         END DO
         A1_AD(i,i) = A1_AD(i,i) + VAL_AD(i)
       END DO
       V_int = matinv( V(1:nZ,1:nZ), Error_Status )
       IF( Error_Status /= SUCCESS  ) THEN
         WRITE( Message,'("Error in matrix inversion matinv( V(1:nZ,1:nZ), Error_Status ) ")' )
         CALL Display_Message( ROUTINE_NAME, &
                               TRIM(Message), &
                               Error_Status )
         RETURN
       END IF

       A_AD = matmul( transpose(V_int), matmul(A1_AD, transpose(V) ) )
       RETURN
     END SUBROUTINE ASYMTX_AD
!
!
     SUBROUTINE ASYMTX2_AD( COS_Angle,n_streams, nZ, V, VAL, V_AD, VAL_AD, A_AD, Error_Status)
       IMPLICIT NONE
       INTEGER :: nZ,Error_Status
       REAL(fp), DIMENSION(:,:) :: V, V_AD, A_AD
       REAL(fp), DIMENSION(:) :: VAL, VAL_AD
       INTEGER :: i,j,n_streams,n
       REAL(fp) :: COS_Angle,d0,d1
       REAL(fp), DIMENSION(nZ,nZ) :: V_int, A1_AD
       REAL(fp) :: b_AD
     !
       n = 0
       IF( nZ /= n_streams ) THEN
       ! additional stream for satellite viewing angle is used.
          d0 = ONE/COS_Angle
          d0 = d0 * d0
          d1 = 100000.0_fp
          DO i = 1, nZ
            if( abs( d0 - VAL(i) ) < d1 .and. abs(V(2,i)) < EIGEN_THRESHOLD ) then
              n = i
              d1 = abs( d0 - VAL(i) )
            end if
          END DO
       END IF
       IF( n /= 0 ) VAL_AD(n) = ZERO

     ! using normoalization condition
       b_AD = ZERO
       !! A1_AD = ZERO
       ! part 4
       DO i = nZ, 1, -1
         DO j = nZ, 1, -1
           b_AD = b_AD + V(j,i)*V_AD(j,i)
           A1_AD(j,i) = V_AD(j,i)
           !! A1_AD(j,i) = A1_AD(j,i) + V_AD(j,i)
         END DO

         DO j = nZ, 1, -1
           A1_AD(j,i) = A1_AD(j,i) - V(j,i)*b_AD
         END DO
         b_AD = ZERO
       END DO

       ! part 3
       !! V_AD = ZERO
       !! V_AD = V_AD + matmul( transpose(V), A1_AD)
       V_AD = matmul( transpose(V), A1_AD)

       ! part 2
       A1_AD = ZERO
       DO i = nZ, 1, -1
         DO j = nZ, 1, -1
          IF( i /= j .and. j /= n ) THEN
            if( abs(VAL(j)-VAL(i)) > EIGEN_THRESHOLD ) then
              A1_AD(i,j) = V_AD(i,j)/(VAL(j)-VAL(i))
            else
              V_AD(i,j) = ZERO
            end if
          ELSE
            V_AD(i,j) = ZERO
          END IF
         END DO
         A1_AD(i,i) = A1_AD(i,i) + VAL_Ad(i)
       END DO

       V_int = matinv( V(1:nZ,1:nZ), Error_Status )
       ! part 1
       !! A_AD = ZERO
       A_AD = matmul( transpose(V_int), matmul(A1_AD, transpose(V) ) )

       RETURN
     END SUBROUTINE ASYMTX2_AD
!
!
 END MODULE CRTM_UTILITY
!


program testdsterf
implicit none
integer, parameter :: n = 4
real(kind=8), dimension(n) :: d
real(kind=8), dimension(n-1) :: e
integer :: info,i

d(1:4) = (/1D+00, 3D+00, 4D+00, 6D+00/)
e(1:3) = (/2D+00, 4D+00, 5D+00/)

call dsterf(n,d,e,info)
DO i = 1, n
    print *, d(i)
end do
end


! This file is F-compatible, except for upper/lower case conventions.
!--------------------------------------------------------------------

Module CubatureRule_T2

USE Precision_Model, ONLY: stnd

Implicit NONE

PRIVATE
PUBLIC :: Rule_T2a

CONTAINS
      SUBROUTINE Rule_T2a(VER,AREA,NUMFUN,Integrand,BASVAL,RGNERR,NUM)

!***BEGIN PROLOGUE Rule_T2a
!***PURPOSE  To compute basic integration rule values and
!            corresponding error estimates.
!***REFER TO Module CubatureRule_General
!      This subroutine is based on DRLTRI, part of DCUTRI. See below.
!***REVISION DATE  950823   (YYMMDD)
!***REVISION DATE  990527   (YYMMDD) (F conversion)
!***AUTHOR
!      Original version
!          Jarle Berntsen, The Computing Centre,
!          University of Bergen, Thormohlens gt. 55,
!          N-5008 Bergen, NORWAY
!          Email:  jarle@eik.ii.uib.no
!          Terje O. Espelid, Department of Informatics,
!          University of Bergen, Thormohlens gt. 55,
!          N-5008 Bergen, NORWAY
!          Email:  terje@eik.ii.uib.no
!      Translation and modification by
!          Ronald Cools, Dept. of Computer Science,
!          Katholieke Universiteit Leuven, Celestijnenlaan 200A,
!          B-3001 Heverlee, Belgium
!          Email:  ronald@cs.kuleuven.ac.be
!
!***REFERENCES
!   J.Berntsen and T.O.Espelid
!     Algorithm 706: DCUTRI: An algorithm for adaptive cubature over a
!     collection of triangles
!   ACM. Trans. Math. Software, Vol. 18 (1992), pp 329-342.
!
!***DESCRIPTION Rule_T2a computes basic integration rule values
!            for a vector of integrands over a triangular region.
!            Rule_T2a also computes estimates for the errors by
!            using several null rule approximations.
!
!   ON ENTRY
!
!   VER    Real array of dimension (2,3).
!          The coordinates of the vertices of the triangle.
!   AREA   Real.
!          The area of the given region.
!   NUMFUN Integer.
!          Number of components of the vector integrand.
!   Integrand Externally declared subroutine for computing
!            all components of the integrand at the given
!            evaluation point.
!            It must have parameters X
!            Input parameters:
!              X(1)      The x-coordinate of the evaluation point.
!              X(2)      The y-coordinate of the evaluation point.
!
!   ON RETURN
!
!   BASVAL Real array of dimension NUMFUN.
!          The values for the basic rule for each component
!          of the integrand.
!   RGNERR Real array of dimension NUMFUN.
!          The error estimates for each component of the integrand.
!   NUM    Integer
!          The number of function evaluations used.
!
!***REFERENCES Berntsen,J. and Espelid,T.O., Degree 13 Symmetric
!              Quadrature Rules for the Triangle, Report
!***ROUTINES CALLED Integrand
!***END PROLOGUE Rule_T2a
!
!   Global variables.
!
      INTERFACE
         FUNCTION Integrand(NUMFUN,X) RESULT(Value)
            USE Precision_Model
            INTEGER, INTENT(IN) :: NUMFUN
            REAL(kind=stnd), DIMENSION(:), INTENT(IN) :: X
            REAL(kind=stnd), DIMENSION(NUMFUN) :: Value
         END FUNCTION Integrand
      END INTERFACE
      INTEGER, INTENT(IN) :: NUMFUN
      INTEGER, INTENT(OUT) :: NUM
      REAL(kind=stnd), INTENT(IN) :: AREA
      REAL(kind=stnd), DIMENSION(:,:), INTENT(IN) :: VER
      REAL(kind=stnd), DIMENSION(:), INTENT(OUT) :: BASVAL, RGNERR
!
!   Constants
!
!   G      Real array of dimension (2,ORBITS).
!          The homogeneous coordinates for the generators of
!          the evaluation points.
!          The integration rule is using symmetric evaluation
!          points and has the structure (1,6,3). That is,
!          1 point of multiplicity 1,
!          6 sets of points of multiplicity 3 and
!          3 sets of points of multiplicity 6.
!          This gives totally 37 evaluation points.
!          In order to reduce the number of loops in Rule_T2a,
!          the 3 loops for the sets of multiplicity 6 are split
!          into 6 loops and added to the loops for the sets of
!          multiplicity 3.
!          The number of weights we have to give with
!          this splitting is 13(ORBITS).
!
!   W      Real array of dimension (9,ORBITS).
!          The weights of the basic rule and the null rules.
!          W(1,1),...,W(1,ORBITS) are weights for the basic rule.
!          W(I,1),...,W(I,ORBITS) for I>1 are null rule weights.
!
      INTEGER, PARAMETER :: ORBITS=13 ! The number of orbits in the Cf.
      REAL(kind=stnd), PARAMETER  :: CRIVAL=0.5_stnd,             &
                                TRES=50*EPSILON(crival),          &
                                FACMED = 10,                      &
                                FACOPT = FACMED/(CRIVAL**2)
!
!  The abscissas are given in homogeneous coordinates.
!
      REAL(kind=stnd), DIMENSION(ORBITS), PARAMETER ::            &
           G1 = (/                                                &
           0.333333333333333333333333333333_stnd,                 &
           0.950275662924105565450352089520_stnd,                 &
           0.171614914923835347556304795551_stnd,                 &
           0.539412243677190440263092985511_stnd,                 &
           0.772160036676532561750285570113_stnd,                 &
           0.009085399949835353883572964740_stnd,                 &
           0.062277290305886993497083640527_stnd,                 &
           0.022076289653624405142446876931_stnd,                 &
           0.018620522802520968955913511549_stnd,                 &
           0.096506481292159228736516560903_stnd,                 &
           0.851306504174348550389457672223_stnd,                 &
           0.689441970728591295496647976487_stnd,                 &
           0.635867859433872768286976979827_stnd/)
      REAL(kind=stnd), DIMENSION(ORBITS), PARAMETER ::            &
           G2 = (/                                                &
           0.333333333333333333333333333333_stnd,                 &
           0.024862168537947217274823955239_stnd,                 &
           0.414192542538082326221847602214_stnd,                 &
           0.230293878161404779868453507244_stnd,                 &
           0.113919981661733719124857214943_stnd,                 &
           0.495457300025082323058213517632_stnd,                 &
           0.468861354847056503251458179727_stnd,                 &
           0.851306504174348550389457672223_stnd,                 &
           0.689441970728591295496647976487_stnd,                 &
           0.635867859433872768286976979827_stnd,                 &
           0.022076289653624405142446876931_stnd,                 &
           0.018620522802520968955913511549_stnd,                 &
           0.096506481292159228736516560903_stnd/)
      REAL(kind=stnd), DIMENSION(2,ORBITS), PARAMETER ::          &
           G =  RESHAPE( SOURCE= (/ G1 , G2 /), SHAPE=(/2,ORBITS/), ORDER=(/2,1/) )
!
!   Weights of the degree 13 quadrature rule.
!
      REAL(kind=stnd), DIMENSION(ORBITS), PARAMETER ::            &
           W1 = (/                                                &
           0.051739766065744133555179145422_stnd,                 &
           0.008007799555564801597804123460_stnd,                 &
           0.046868898981821644823226732071_stnd,                 &
           0.046590940183976487960361770070_stnd,                 &
           0.031016943313796381407646220131_stnd,                 &
           0.010791612736631273623178240136_stnd,                 &
           0.032195534242431618819414482205_stnd,                 &
           0.015445834210701583817692900053_stnd,                 &
           0.017822989923178661888748319485_stnd,                 &
           0.037038683681384627918546472190_stnd,                 &
           0.015445834210701583817692900053_stnd,                 &
           0.017822989923178661888748319485_stnd,                 &
           0.037038683681384627918546472190_stnd/)
!
!   Weights of the first null rule of degree 7.
!
      REAL(kind=stnd), DIMENSION(ORBITS), PARAMETER ::            &
           W2 = (/                                                &
          -0.077738051051462052051304462750_stnd,                 &
           0.001640389740236881582083124927_stnd,                 &
           0.078124083459915167386776552733_stnd,                 &
          -0.030706528522391137165581298102_stnd,                 &
           0.010246307817678312345028512621_stnd,                 &
           0.012586300774453821540476193059_stnd,                 &
          -0.043630506151410607808929481439_stnd,                 &
          -0.004567055157220063810223671248_stnd,                 &
           0.003393373439889186878847613140_stnd,                 &
           0.0_stnd,                                              &
          -0.004567055157220063810223671248_stnd,                 &
           0.003393373439889186878847613140_stnd,                 &
           0.0_stnd/)
!
!   Weights of the second null rule of degree 7.
!
      REAL(kind=stnd), DIMENSION(ORBITS), PARAMETER ::            &
           W3 = (/                                                &
          -0.064293709240668260928898888457_stnd,                 &
           0.003134665264639380635175608661_stnd,                 &
           0.007822550509742830478456728602_stnd,                 &
           0.048653051907689492781049400973_stnd,                 &
           0.032883327334384971735434067029_stnd,                 &
          -0.017019508374229390108580829589_stnd,                 &
           0.025973557893399824586684707198_stnd,                 &
          -0.010716753326806275930657622320_stnd,                 &
           0.018315629578968063765722278290_stnd,                 &
          -0.047607080313197299401024682666_stnd,                 &
          -0.010716753326806275930657622320_stnd,                 &
           0.018315629578968063765722278290_stnd,                 &
          -0.047607080313197299401024682666_stnd/)
!
!   Weights of the first degree 5 null rule.
!
!
      REAL(kind=stnd), DIMENSION(ORBITS), PARAMETER ::            &
           W4 = (/                                                &
           0.021363205584741860993131879186_stnd,                 &
           0.022716410154120323440432428315_stnd,                 &
          -0.026366191271182090678117381002_stnd,                 &
           0.029627021479068212693155637482_stnd,                 &
           0.004782834546596399307634111034_stnd,                 &
           0.004178667433984132052378990240_stnd,                 &
          -0.065398996748953861618846710897_stnd,                 &
          -0.033589813176131630980793760168_stnd,                 &
           0.033018320112481615757912576257_stnd,                 &
           0.012241086002709814125707333127_stnd,                 &
          -0.033589813176131630980793760168_stnd,                 &
           0.033018320112481615757912576257_stnd,                 &
           0.012241086002709814125707333127_stnd/)
!
!   Weights of the second degree 5 null rule.
!
      REAL(kind=stnd), DIMENSION(ORBITS), PARAMETER ::            &
           W5 = (/                                                &
          -0.046058756832790538620830792345_stnd,                 &
           0.005284159186732627192774759959_stnd,                 &
           0.009325799301158899112648198129_stnd,                 &
          -0.006101110360950124560783393745_stnd,                 &
          -0.056223328794664871336486737231_stnd,                 &
          -0.062516479198185693171971930698_stnd,                 &
           0.022428226812039547178810743269_stnd,                 &
          -0.000026014926110604563130107142_stnd,                 &
           0.032882099937471182365626663487_stnd,                 &
           0.018721740987705986426812755881_stnd,                 &
          -0.000026014926110604563130107142_stnd,                 &
           0.032882099937471182365626663487_stnd,                 &
           0.018721740987705986426812755881_stnd/)
!
!   Weights of first degree 3 null rule.
!
      REAL(kind=stnd), DIMENSION(ORBITS), PARAMETER ::            &
           W6 = (/                                                &
           0.080867117677405246540283712799_stnd,                 &
          -0.033915806661511608094988607349_stnd,                 &
           0.014813362053697845461526433401_stnd,                 &
           0.001442315416337389214102507204_stnd,                 &
          -0.024309696484708683486455879210_stnd,                 &
          -0.005135085639122398522835391664_stnd,                 &
          -0.034649417896235909885490654650_stnd,                 &
           0.035748423431577326597742956780_stnd,                 &
           0.024548155266816447583155562333_stnd,                 &
          -0.032897267038856299280541675107_stnd,                 &
           0.035748423431577326597742956780_stnd,                 &
           0.024548155266816447583155562333_stnd,                 &
          -0.032897267038856299280541675107_stnd/)
!
!   Weights of second degree 3 null rule.
!
      REAL(kind=stnd), DIMENSION(ORBITS), PARAMETER ::            &
           W7 = (/                                                &
          -0.038457863913548248582247346193_stnd,                 &
          -0.055143631258696406147982448269_stnd,                 &
          -0.021536994314510083845999131455_stnd,                 &
           0.001547467894857008228010564582_stnd,                 &
           0.057409361764652373776043522086_stnd,                 &
          -0.040636938884669694118908764512_stnd,                 &
          -0.020801144746964801777584428369_stnd,                 &
           0.019490770404993674256256421103_stnd,                 &
           0.002606109985826399625043764771_stnd,                 &
           0.023893703367437102825618048130_stnd,                 &
           0.019490770404993674256256421103_stnd,                 &
           0.002606109985826399625043764771_stnd,                 &
           0.023893703367437102825618048130_stnd/)
!
!   Weights of first degree 1 null rule.
!
      REAL(kind=stnd), DIMENSION(ORBITS), PARAMETER ::            &
           W8 = (/                                                &
           0.074839568911184074117081012527_stnd,                 &
          -0.004270103034833742737299816615_stnd,                 &
           0.049352639555084484177095781183_stnd,                 &
           0.048832124609719176627453278550_stnd,                 &
           0.001042698696559292759051590242_stnd,                 &
          -0.044445273029113458906055765365_stnd,                 &
          -0.004670751812662861209726508477_stnd,                 &
          -0.015613390485814379318605247424_stnd,                 &
          -0.030581651696100000521074498679_stnd,                 &
           0.010801113204340588798240297593_stnd,                 &
          -0.015613390485814379318605247424_stnd,                 &
          -0.030581651696100000521074498679_stnd,                 &
           0.010801113204340588798240297593_stnd/)
!
!   Weights of second degree 1 null rule.
!
      REAL(kind=stnd), DIMENSION(ORBITS), PARAMETER ::            &
           W9 = (/                                                &
           0.009373028261842556370231264134_stnd,                 &
          -0.074249368848508554545399978725_stnd,                 &
           0.014709707700258308001897299938_stnd,                 &
           0.009538502545163567494354463302_stnd,                 &
          -0.014268362488069444905870465047_stnd,                 &
           0.040126396495352694403045023109_stnd,                 &
           0.028737181842214741174950928350_stnd,                 &
          -0.031618075834734607275229608099_stnd,                 &
           0.016879961075872039084307382161_stnd,                 &
           0.010878914758683152984395046434_stnd,                 &
          -0.031618075834734607275229608099_stnd,                 &
           0.016879961075872039084307382161_stnd,                 &
           0.010878914758683152984395046434_stnd/)
      REAL(kind=stnd), DIMENSION(9,ORBITS), PARAMETER ::          &
           W =  RESHAPE( SOURCE= (/ W1,W2,W3,W4,W5,W6,W7,W8,W9 /),&
                   SHAPE=(/9,ORBITS/), ORDER=(/2,1/) )
!
!  Local variables
!
!
!   NullRule  Real array of dimension (NUMFUN,8).
!          A work array.
!
      INTEGER :: I,J,L
      REAL(kind=stnd):: Z1,Z2,Z3,R1,R2,R3,R,DEG7,DEG5,DEG3,DEG1,NOISE
      REAL(kind=stnd), DIMENSION(NUMFUN,8) :: NullRule
      REAL(kind=stnd), DIMENSION(2,3)      :: X
!
!***FIRST EXECUTABLE STATEMENT Rule_T2a
!
!   Compute contributions from the center of the triangle.
!
      X(1:2,1) = (VER(1:2,1)+VER(1:2,2)+VER(1:2,3))/3
      RGNERR=Integrand(NUMFUN,X(:,1))
      BASVAL(1:NUMFUN) = W(1,1)*RGNERR(1:NUMFUN)
      DO J = 1,NUMFUN
          NullRule(J,1:8) = W(2:9,1)*RGNERR(J)
      END DO
!
!   Compute contributions from points with
!   multiplicity 3.
!
      DO I = 2,ORBITS
          Z1 = G(1,I)
          Z2 = G(2,I)
          Z3 = 1 - Z1 - Z2
          X(1:2,1) = Z1*VER(1:2,1) + Z2*VER(1:2,2) + Z3*VER(1:2,3)
          X(1:2,2) = Z2*VER(1:2,1) + Z3*VER(1:2,2) + Z1*VER(1:2,3)
          X(1:2,3) = Z3*VER(1:2,1) + Z1*VER(1:2,2) + Z2*VER(1:2,3)
          DO L = 1,3
              RGNERR=Integrand(NUMFUN,X(:,L))
              BASVAL(1:NUMFUN) = BASVAL(1:NUMFUN) + W(1,I)*RGNERR(1:NUMFUN)
              DO J = 1,NUMFUN
                  NullRule(J,1:8) = NullRule(J,1:8) + W(2:9,I)*RGNERR(J)
              END DO
          END DO
      END DO
!
!    Compute errors.
!
      DO J = 1,NUMFUN
          NOISE = ABS(BASVAL(J))*TRES
          DEG7 = SQRT(NullRule(J,1)**2+NullRule(J,2)**2)
          IF ( DEG7 <= NOISE) THEN
              RGNERR(J) = NOISE
          ELSE
          DEG5 = SQRT(NullRule(J,3)**2+NullRule(J,4)**2)
          DEG3 = SQRT(NullRule(J,5)**2+NullRule(J,6)**2)
          DEG1 = SQRT(NullRule(J,7)**2+NullRule(J,8)**2)
          IF (DEG5 /= 0) THEN
                                R1 = DEG7/DEG5
                         ELSE
                                R1 = 1
          END IF
          IF (DEG3 /= 0) THEN
                                R2 = DEG5/DEG3
                         ELSE
                                R2 = 1
          END IF
          IF (DEG1 /= 0) THEN
                                R3 = DEG3/DEG1
                         ELSE
                                R3 = 1
          END IF
          R = MAX(R1,R2,R3)
          IF (R >= 1) THEN
              RGNERR(J) = 10*MAX(DEG1,DEG3,DEG5,DEG7)
          ELSE IF (R >= CRIVAL) THEN
              RGNERR(J) = facmed*R*DEG7
          ELSE
              RGNERR(J) = facopt* (R**3)*DEG7
          END IF
          RGNERR(J) = MAX(NOISE,RGNERR(J))
          END IF
          RGNERR(J) = AREA*RGNERR(J)
          BASVAL(J) = AREA*BASVAL(J)
          RGNERR(J) = MIN(ABS(BASVAL(J)),RGNERR(J))
      END DO
      NUM = 37
      RETURN
      END SUBROUTINE Rule_T2a

END MODULE CubatureRule_T2


program vinay
  print *, (3 - (2) ** 2 ** 3)
 end program vinay