real(kind=sp) function computationally_heavy(i)
    implicit none
    integer, intent(in) :: i
    real(kind=sp) :: x
    x = 2.0_sp*real(i, kind=sp)/m
    computationally_heavy = erf(x)
end function computationally_heavy

real(kind=sp) function whatever(j)
    implicit none
    integer, intent(in) :: j
    real(kind=sp) :: x
    x = 2.0_sp*real(j, kind=sp)/n
    whatever = sqrt(x)
end function whatever

real(kind=sp) function row_func(j)
    implicit none
    integer, intent(in) :: j
    real(kind=sp) :: x
    x = 2.0*real(j, kind=sp)/n
    row_func = exp(-x)
end function row_func


      real             function SRLOG (X)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c  File srlog contains user callable procedures srlog & srlog1, and
c               lower level procedure srlog2.
c  srlog(x)  computes x - 1 - ln(x).
c  srlog1(x) computes x - ln(1 + x).
c>> 1996-03-30 SRLOG  Krogh  Added external statements.
C>> 1994-11-09 CLL Edited to avoid ENTRY statement.
C>> 1994-10-20 SRLOG Krogh  Changes to use M77CON
C>> 1994-05-23 SRLOG WVS JPL Combine SRLOG and SRLOG1
C>> 1994-05-23 SRLOG WVS JPL Make SP and DP alike using CHGTYP
C>> 1993-05-06 SRLOG WVS JPL Conversion from NSWC to Math 77
C ----------------------------------------------------------------------
c--S replaces "?": ?RLOG, ?RLOG1, ?RLOG2
C     ==================================================================
C             EVALUATION OF THE FUNCTION X - 1 - LN(X)
C     ------------------------------------------------------------------
      external srlog2
      real             srlog2, r, x
C     ------------------------------------------------------------------
      R = (X - 0.5E0) - 0.5E0
      IF (X .LT. 0.61E0 .OR. X .GT. 1.57E0) THEN
         SRLOG = R - LOG(X)
      else
         SRLOG = SRLOG2(R)
      endif
      end
c     ==================================================================
      real             function SRLOG1 (X)
C             EVALUATION OF THE FUNCTION X - LN(1 + X)
C     ------------------------------------------------------------------
      external srlog2
      real             srlog2, r, x
C     ------------------------------------------------------------------
      IF (X .LT. -0.39E0 .OR. X .GT. 0.57E0) THEN
         R = (X + 0.5E0) + 0.5E0
         SRLOG1 = X - LOG(R)
      else
         SRLOG1 = SRLOG2(X)
      endif
      end
c     ==================================================================
      real             function SRLOG2(RIN)
C            Complete computation started by SRLOG or SRLOG1.
C     ------------------------------------------------------------------
      external R1MACH
      real             R1MACH
      REAL             A, B, R, RIN, ROUND, T, U, UP2, W, Z
      SAVE ROUND
      REAL             C1, C2, C3, C4, C5
      REAL             P0, P1, P2, P3, Q1, Q2, Q3, Q4
      REAL             R0, R1, R2, S1, S2
c ------------------------
C     CI = 1/(2I + 1)
c ------------------------
      PARAMETER (C1 = 1.0E0 / 3.0E0)
      PARAMETER (C2 = 1.0E0 / 5.0E0)
      PARAMETER (C3 = 1.0E0 / 7.0E0)
      PARAMETER (C4 = 1.0E0 / 9.0E0)
      PARAMETER (C5 = 1.0E0 / 11.0E0)
c ------------------------
C     A = SRLOG (0.7)
C     B = SRLOG (4/3)
c ------------------------
      DATA A /.566749439387323789126387112411845E-01/
      DATA B /.456512608815524058941143273395059E-01/
c ------------------------
      DATA P0 / .7692307692307692307680E-01/,
     *     P1 /-.1505958055914600184836E+00/,
     *     P2 / .9302355725278521726994E-01/,
     *     P3 /-.1787900022182327735804E-01/
      DATA Q1 /-.2824412139355646910683E+01/,
     *     Q2 / .2892424216041495392509E+01/,
     *     Q3 /-.1263560605948009364422E+01/,
     *     Q4 / .1966769435894561313526E+00/
c ------------------------
      DATA R0/ .333333333333333E+00/, R1/-.224696413112536E+00/,
     *     R2/ .620886815375787E-02/
      DATA S1/-.127408923933623E+01/, S2/ .354508718369557E+00/
c ------------------------
      DATA ROUND /-1.0E0/
C     ------------------------------------------------------------------
C
C                 ARGUMENT REDUCTION
C
      R = RIN
      IF (R .LT. -0.18E0) THEN
         U = (10.0E0*R + 3.0E0)/7.0E0
         UP2 = U + 2.0E0
         W = A - U*0.3E0
      ELSE IF (R .GT. 0.18E0) THEN
         T = 0.75E0*R
         U = T - 0.25E0
         UP2 = T + 1.75E0
         W = B + U/3.0E0
      ELSE
         U = R
         UP2 = U + 2.0E0
         W = 0.0E0
      END IF
      IF (ROUND .LT. 0.0E0) ROUND = R1MACH(4)
C
C                  SERIES EXPANSION
C
      R = U/UP2
      T = R*R
      IF (ROUND .GT. 5.0E-14) THEN
         Z = ((R2*T + R1)*T + R0)/((S2*T + S1)*T + 1.0E0)
      ELSE
C
C        Z IS (AT FIRST) A MINIMAX APPROXIMATION OF THE SERIES
C
C               C6 + C7*R**2 + C8*R**4 + ...
C
C        FOR THE INTERVAL (0.0, 0.375). THE APPROXIMATION IS ACCURATE
C        TO WITHIN 1.6 UNITS OF THE 21-ST SIGNIFICANT DIGIT.
C
         Z = (((P3*T + P2)*T + P1)*T + P0)/
     *       ((((Q4*T + Q3)*T + Q2)*T + Q1)*T + 1.0E0)
C
         Z = ((((Z*T + C5)*T + C4)*T + C3)*T + C2)*T + C1
      END IF
      SRLOG2 = R*(U - 2.0E0*T*Z) + W
      END


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Solve the linear equation SX = U for X where X is the COEF matrix
C and U is the UMOM matrix.  This routine sets up the call for DGELG
C which actually does the work.
C
      SUBROUTINE LSPFIT(M,MOM,UMOM,coef,ier)
      IMPLICIT NONE
      INTEGER M,IER
      REAL*8 MOM(1),UMOM(1)
      REAL*8 S(5151)		!Output S matrix
                                !M <= 100, therfore the max size for S should
                                !not be greater than 5151.
                                !(i.e. (100+1)(100+2)/2 = 5151)

      REAL*8 COEF(1)		!Output coefficients

      REAL*8 EPS/1.D-15/
      INTEGER*4 NU,IX,IY,IS,IM,J,K,L,JJ,KK

C
C     ...Check for boundary conditions
      IF ((M .LT. 0) .OR. (M .GT. 100)) THEN
          IER = 1
         CALL MABEND ('Invalid M value.  See lspfit.hlp.')
      END IF

C
C     ....Generate S-array from moments
      IS = 0
C
      DO 20 J=0,M
      DO 20 K=0,J
C
      DO 10 JJ=0,M
      DO 10 KK=0,JJ
      IX = (JJ-KK) + (J-K)		!power of x
      IY = KK + K			!power of y
      L = IX + IY			!degree of term
      IM = (L*(L+1))/2 + IY + 1
      IS = IS + 1
   10 S(IS) = MOM(IM)

   20 CONTINUE
C
      NU = (M+1)*(M+2)/2
      CALL MVE(8,2*NU,UMOM,COEF,1,1)
CCC      CALL PRNT(8,2*NU,COEF,'UMOM=.')
CCC      CALL PRNT(8,NU*NU,S,'S=.')
      CALL DGELG(COEF,S,NU,2,EPS,IER)
      RETURN
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Constrained Linear FIT routine CLFIT.  Finds coefficients a,b,e,f such that
C          U = a*X + b*Y + e
C          V =-b*X + a*Y + f
C subject to various constraints on a,b,e, and f.
C
      SUBROUTINE CLFIT(IFIT,MOM,UMOM,coef,ier)
      IMPLICIT NONE
      INTEGER IFIT,IER
      REAL*8 MOM(6),UMOM(6),COEF(6)

      INTEGER ROTATE,SCALE,OFFSET
      REAL*8 N,X,Y,X2,Y2,U,XU,YU,V,XV,YV,A,B,E,F,R,R1,R2
      REAL*8 EPS/1.D-15/
C
C         IFIT  ROTATE SCALE  OFFSET
C          1      0      0      1
C          2      0      1      0
C          3      0      1      1
C          4      1      0      0
C          5      1      0      1
C          6      1      1      0
C          7      1      1      1
C
      IER = -1
      IF (IFIT.LT.0.OR.IFIT.GT.7) RETURN
      IF (MOM(1).LE.1) RETURN
      N = MOM(1)
      X = MOM(2)
      Y = MOM(3)
      X2 = MOM(4)
      Y2 = MOM(6)
      U = UMOM(1)
      XU = UMOM(2)
      YU = UMOM(3)
      V = UMOM(4)
      XV = UMOM(5)
      YV = UMOM(6)
C          INITIALIZE WITH IDENTITY TRANSORMATION
      A = 1.D0
      B = 0.D0
      E = 0.D0
      F = 0.D0
      OFFSET = MOD(IFIT,2)
      SCALE = MOD(IFIT/2,2)
      ROTATE = IFIT/4
      R1 = XU + YV
      R2 = YU - XV
      R = X2 + Y2
      IF (OFFSET.EQ.1) THEN
         R1 = N*R1 - (X*U+Y*V)
         R2 = N*R2 - (Y*U-X*V)
         R = N*R - (X*X+Y*Y)
      ENDIF
      IF(SCALE.EQ.0) R=DSQRT(R1*R1+R2*R2)
      IF (ROTATE+SCALE.GT.0) THEN
         IF (DABS(R).LE.EPS) RETURN
         A = R1/R
         IF (ROTATE.EQ.1) B=R2/R
      ENDIF
      IF (OFFSET.EQ.1) THEN
         E = (U - A*X - B*Y)/N
         F = (V + B*X - A*Y)/N
      ENDIF

      COEF(1) = E
      COEF(2) = A
      COEF(3) = B
      COEF(4) = F
      COEF(5) = -B
      COEF(6) = A
      IER = 0
      RETURN
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Compute the moments of the x,y and u,v coordinates.
C
      SUBROUTINE MOMENT(NPOW,PTS,N,mom,umom)
      IMPLICIT NONE
      INTEGER NPOW,N
      REAL*4 PTS(4,1)
      REAL*8 MOM(1),UMOM(1)

      INTEGER MPOW,IPOW,NU,NM,I,J,K,L,IP1
      REAL*8 XI,YI,UI,VI,U,V,Z
C
      MPOW = 2*NPOW
      NU = (NPOW+1)*(NPOW+2)/2
      NM = (MPOW+1)*(MPOW+2)/2
      U = 0.D0
      V = 0.D0
      CALL MVE(8,NM,U,MOM,0.,1)
      CALL MVE(8,2*NU,U,UMOM,0.,1)
C
      DO 10 K=1,N
      XI = PTS(1,K)
      YI = PTS(2,K)
      UI = PTS(3,K)
      VI = PTS(4,K)
      U = U + UI
      V = V + VI
      L = 1
C
      DO 10 I=1,MPOW
      IP1 = I + 1
      IPOW = I
      Z = XI**I
      DO 10 J=1,IP1
      L = L + 1
      IF (J.GT.1) THEN
         IF (J.LT.IP1) THEN
            Z = XI**IPOW*YI**(I-IPOW)
         ELSE
            Z = YI**I
         ENDIF
      ENDIF
      MOM(L) = MOM(L) + Z
      IF (I.LE.NPOW) THEN
         UMOM(L) = UMOM(L) + UI*Z
         UMOM(NU+L) = UMOM(NU+L) + VI*Z
      ENDIF
   10 IPOW = IPOW - 1
C
      MOM(1) = MOM(1) + N
      UMOM(1) = UMOM(1) + U
      UMOM(NU+1) = UMOM(NU+1) + V
      RETURN
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Compute RMS error of polynomial fit.
C
      SUBROUTINE RMSFIT(MODE,NPOW,PTS,N,coef,drms,dmax,imax)
      IMPLICIT NONE
      INTEGER MODE,NPOW,N,IMAX
      REAL*4 PTS(4,1)
      REAL*8 COEF(100),DRMS,DMAX

      INTEGER K
      REAL*8 DU,DV
      REAL*4 X,Y,U,V
C
      DRMS = 0.D0
      DMAX = 0.D0
      IMAX = 0
C
      DO 20 K=1,N
      X = PTS(1,K)
      Y = PTS(2,K)
      CALL POLYTRAN(NPOW,COEF,X,Y,U,V)
      DU = U - PTS(3,K)
      DV = V - PTS(4,K)
      DU = DU*DU + DV*DV
      IF (DMAX.LT.DU) THEN
         DMAX = DU
         IMAX = K
      ENDIF
      DRMS = DRMS + DU
      IF (MODE.EQ.1) THEN
         PTS(3,K) = U
         PTS(4,K) = V
      ENDIF
   20 CONTINUE
C
      DMAX = SQRT(DMAX)
      DRMS = DSQRT(DRMS/N)
      RETURN
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Compute coordinates (U0,V0) as a polynomial of coordinates (X0,Y0)
C  u(x,y) = a00 + a10*x + a01*y + a20*x**2 + a11*x*y + a02*y**2 + ... + a0m*y**m
C  v(x,y) = b00 + b10*x + b01*y + b20*x**2 + b11*x*y + b02*y**2 + ... + b0m*y**m
C
      SUBROUTINE POLYTRAN(M,COEF,X0,Y0,u0,v0)
      IMPLICIT NONE
      INTEGER M			!Order of the polynomial
      REAL*8 COEF(100)		!Coefficients aij and bij
      REAL*4 X0,Y0,U0,V0	!Input and outputs coordinates

      REAL*8 X,Y,U,V,Z		!All calculations done in double precision
      INTEGER NU,J,K,L
C
      NU = (M+1)*(M+2)/2	!Index to start of V values
      X = X0			!Convert inputs to double precision
      Y = Y0
      U = 0.
      V = 0.
      L = 0
C
      DO 10 J=0,M
      DO 10 K=0,J
      Z = X**(J-K)*Y**K
      L = L + 1
      U = U + COEF(L)*Z
   10 V = V + COEF(NU+L)*Z
C
      U0 = U			!Convert outputs to single precision
      V0 = V

      RETURN
      END


module statistics
	use constants, 		only:			dp, aUtoEv, kBoltz_Eh_K
	!
	implicit none

	public					::			fd_stat,		fd_stat_deriv, 			&
										fd_get_N_el
	private

	interface fd_stat
		module procedure	d0_fd_stat
		module procedure	d1_fd_stat
	end interface fd_stat

	interface fd_stat_deriv
		module procedure	d0_fd_stat_deriv
		module procedure	d1_fd_stat_deriv
	end interface fd_stat_deriv

	interface fd_get_N_el
		module procedure	d0_fd_get_N_el
		module procedure	d1_fd_get_N_el
	end interface fd_get_N_el

	save

	real(dp),	parameter	::			min_temp	= 	1e-2_dp
	logical					::			t_zero_warn	=	.False.

contains

	real(dp) pure function d0_fd_stat(e_band, e_fermi,	T_kelvin)
		real(dp), 		intent(in)			::	e_band, e_fermi, T_kelvin
		real(dp)							::	T_smear
		!
		d0_fd_stat		=	0.0_dp
		!
		if(	 T_kelvin > min_temp ) 				then
			!
			!	FINITE TEMPERATURE
			T_smear			=	kBoltz_Eh_K		*	T_kelvin
			d0_fd_stat		 	= 	1.0_dp	/	(	1.0_dp	+	exp(	(e_band	- e_fermi)	/	(T_smear)))
			!
			!
		else if(	e_band < e_fermi	)  		then
			!
			!	ZERO TEMPERATURE
			d0_fd_stat	=	1.0_dp
		end if
		!
		!
		return
	end function

	pure function d1_fd_stat(e_band, ef_lst, T_kelvin)	result(fd_lst)
		real(dp),					intent(in)		::	e_band, ef_lst(:), T_kelvin
		real(dp),	allocatable						::	fd_lst(:)
		real(dp)									::	T_smear
		integer										::	ef_idx
		!
		allocate(	fd_lst(size(ef_lst,1))		)
		fd_lst	=	0.0_dp
		!
		if(T_kelvin > min_temp )	then
			!
			!	T/=0		FERMI-DIRAC SMEARING
			T_smear			=	kBoltz_Eh_K		*	T_kelvin
			do ef_idx	=	1, size(ef_lst,1)
				fd_lst(ef_idx)	=	1.0_dp /	(	1.0_dp + exp(	( e_band	- ef_lst(ef_idx) )	/	T_smear	))
			end do
		else
			!
			!	T==0		STEPFUNCTION
			do ef_idx	=	1, size(ef_lst,1)
				if(	e_band < ef_lst(ef_idx)	)		fd_lst(ef_idx)	=	1.0_dp
			end do
		end if
		!
		return
	end function

	pure function d0_fd_get_N_el(en_k, e_fermi, T_kelvin)	result(N_el)
		real(dp),		intent(in)			::	en_k(:), e_fermi, T_kelvin
		real(dp)							::	N_el
		integer								::	n
		!
		N_el	=	0.0_dp
		!
		do n = 1, size(en_k)
			N_el	=	N_el	+	fd_stat(en_k(n),	e_fermi, T_kelvin)
		end do
		!
		return
	end function

	pure function d1_fd_get_N_el(en_k, ef_lst, T_kelvin)	result(N_el_lst)
		real(dp),		intent(in)			::	en_k(:), ef_lst(:), T_kelvin
		real(dp),		allocatable			::	N_el_lst(:)
		integer								::	n
		!
		allocate(	N_el_lst( size(ef_lst,1))		)
		N_el_lst	=	0.0_dp
		!
		do n = 1, size(en_k)
			N_el_lst(:)	=	N_el_lst(:)		+	fd_stat(en_k(n),	ef_lst(:), T_kelvin)
		end do
		!
		return
	end function

	real(dp) pure function d0_fd_stat_deriv(e_band, e_fermi, T_kelvin)
		real(dp), 		intent(in)			::	e_band, e_fermi, T_kelvin
		real(dp)							::	T_smear, x
		!
		!	w90git:
		!if (abs (x) .le.36.0) then
        ! 	utility_w0gauss = 1.00_dp / (2.00_dp + exp ( - x) + exp ( + x) )
        !  	! in order to avoid problems for large values of x in the e
       	!else
        !	utility_w0gauss = 0.0_dp
       	!endif
       	!
       	d0_fd_stat_deriv		=	0.0_dp
       	!
       	if(	T_kelvin > min_temp	)								then
       		T_smear			=	kBoltz_Eh_K		*	T_kelvin
       		x				=	(e_band	- e_fermi) / T_smear
       		!
       		!
       		d0_fd_stat_deriv	=	1.00_dp 	/ 	(	2.00_dp + exp( x ) + exp( -x ) 	)
       	end if

		return
	end function

	function d1_fd_stat_deriv(fd_distrib, T_kelvin) result(fd_deriv)
		real(dp), 		intent(in)			::	fd_distrib(:,:), T_kelvin
		real(dp),		allocatable			::	fd_deriv(:,:)
		integer								::	ef_idx, n_ef, n_wf, n
		!
		!	w90git:
		!if (abs (x) .le.36.0) then
        ! 	utility_w0gauss = 1.00_dp / (2.00_dp + exp ( - x) + exp ( + x) )
        !  	! in order to avoid problems for large values of x in the e
       	!else
        !	utility_w0gauss = 0.0_dp
       	!endif
       	!		uses
       	!			2 cosh(x)	=	exp(x)	+ exp(-x)
       	!
       	!
       	n_ef	=	size(fd_distrib,1)
       	n_wf	=	size(fd_distrib,2)
       	!
       	allocate(	fd_deriv(	n_ef,	n_wf 	))
       	fd_deriv		=	0.0_dp
       	!
       	!
      	do n = 1, n_wf
       		do ef_idx = 1, n_ef
       			fd_deriv(ef_idx,n)	=1.00_dp 	/ 	 (		2.00_dp	+ 2.00_dp *	cosh( fd_distrib(ef_idx,n) )	)
       		end do
       	end do
       	!
       	!
       	if(T_kelvin < min_temp .and. .not. t_zero_warn )	then
       		write(*,*)	"[d1_fd_stat_deriv]: WARNING T=0; fd_stat_deriv only defined for finite Temeperature (try to set Tkelvin>0)"
       		t_zero_warn	=	.True.
       	end if
       	!
		return
	end function

end module statistics


      real function fslq(q,n,c1,y)
c
c     + + + PURPOSE + + +
c
c     Function FSLQ computes the friction slope at the channel outlet.
c
c     Called from: SR FRICHN
c     Author(s): Ascough II, R. van der Zweep, V. Lopes
c     Reference in User Guide:
c
c     Version:
c     Date recoded:
c     Recoded by: Jim Ascough II
c
c     + + + KEYWORDS + + +
c
c     + + + PARAMETERS + + +
c
c     + + + ARGUMENT DECLARATIONS + + +
c
      real n, q, c1, y
c
c     + + + ARGUMENT DEFINITIONS + + +
c
c     n  -
c     q  -
c     c1 -
c     y  -
c
c     + + + COMMON BLOCKS + + +
c
c     + + + LOCAL VARIABLES + + +
c
c     + + + LOCAL DEFINITIONS + + +
c
c     + + + SAVES + + +
c
c     + + + SUBROUTINES CALLED + + +
c
c     + + + DATA INITIALIZATIONS + + +
c
c     + + + END SPECIFICATIONS + + +
c
c
      fslq = (q*n/(1.49*c1*y**(8.0/3.0))) ** 2.0
c
      return
      end


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C BenchIT - Performance Measurement for Scientific Applications
C Contact: developer@benchit.org
C
C For license details see COPYING in the package base directory
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Kernel: Matrix Multiply (F77)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

	SUBROUTINE multaijk( a, b, c, n)
	INTEGER*4 n,i,j,k
	double precision a(n,n), b(n,n), c(n,n)
!$omp parallel do shared(a,b,c,n) private(i,j,k)
	do 100 i=1,n
	do 100 j=1,n
	do 100 k=1,n
	   c(i,j)=c(i,j)+a(i,k)*b(k,j)
 100	CONTINUE
	RETURN
	END
c
	SUBROUTINE multaikj( a, b, c, n)
	INTEGER*4 n,i,j,k
	double precision a(n,n), b(n,n), c(n,n)
!$omp parallel do shared(a,b,c,n) private(i,j,k)
	do 100 i=1,n
	do 100 k=1,n
	do 100 j=1,n
	   c(i,j)=c(i,j)+a(i,k)*b(k,j)
 100	CONTINUE
	RETURN
	END
c
	SUBROUTINE multajik( a, b, c, n)
	INTEGER*4 n,i,j,k
	double precision a(n,n), b(n,n), c(n,n)
!$omp parallel do shared(a,b,c,n) private(i,j,k)
	do 100 j=1,n
	do 100 i=1,n
	do 100 k=1,n
	   c(i,j)=c(i,j)+a(i,k)*b(k,j)
 100	CONTINUE
	RETURN
	END
c
	SUBROUTINE multajki( a, b, c, n)
	INTEGER*4 n,i,j,k
	double precision a(n,n), b(n,n), c(n,n)
!$omp parallel do shared(a,b,c,n) private(i,j,k)
	do 100 j=1,n
	do 100 k=1,n
	do 100 i=1,n
	   c(i,j)=c(i,j)+a(i,k)*b(k,j)
 100	CONTINUE
	RETURN
	END
c
	SUBROUTINE multakij( a, b, c, n)
	INTEGER*4 n,i,j,k
	double precision a(n,n), b(n,n), c(n,n)
!$omp parallel do shared(a,b,c,n) private(i,j,k)
	do 100 k=1,n
	do 100 i=1,n
	do 100 j=1,n
	   c(i,j)=c(i,j)+a(i,k)*b(k,j)
 100	CONTINUE
	RETURN
	END
c
	SUBROUTINE multakji( a, b, c, n)
	INTEGER*4 n,i,j,k
	double precision a(n,n), b(n,n), c(n,n)
!$omp parallel do shared(a,b,c,n) private(i,j,k)
	do 100 k=1,n
	do 100 j=1,n
	do 100 i=1,n
	   c(i,j)=c(i,j)+a(i,k)*b(k,j)
 100	CONTINUE
	RETURN
	END


      subroutine optr03(a,ia,c,ic,q,iq,r,ir,p,b,d,ci,cs,x,w,iw,ire,ipvt,
     &                  jpvt,alfa,ira,n,m,mi,mi1,md,mif,mdf,modo,ind,imp
     &                  ,io,iter)
C     SUBROUTINE OPTR03(A,IA,C,IC,Q,IQ,R,IR,P,B,D,CI,CS,X,W,IW,IRE,IPVT,
C    &                  JPVT,ALFA,IRA,N,M,MI,MI1,MD,MIF,MDF,MODO,IND,IMP
C    &                  ,IO,ITER)
C
C***********************************************************************
C                                                                      *
C                                                                      *
C      Copyright:       Eduardo Casas Renteria                         *
C                       Cecilia Pola Mendez                            *
C                                                                      *
C       Departamento de Matematicas,Estadistica y Computacion          *
C       -----------------------------------------------------          *
C                       UNIVERSIDAD DE CANTABRIA                       *
C                       ------------------------                       *
C                            OCTUBRE  1989 Version 1.1                 *
C                            JULIO    2001 Version 2.1                 *
C                            JULIO    2005                             *
C                                                                      *
C***********************************************************************
C
C     OBJETIVO:
C        La minimizacion  de un funcional cuadratico  con restricciones
C        lineales,  (de acotacion, igualdad  y  desigualdad), sobre las
C        variables:
C
C          (1)  CI(I) <= X(I) <= CS(I), I=1,N
C          (2)  <(C(1,J),C(2,J),...,C(N,J)),X>  = D(J), J=1,MI
C          (3)  <(C(1,J),C(2,J),...,C(N,J)),X> <= D(J), J=MI+1,MI+MD
C
C        El  funcional  puede  presentar  terminos  lineales  a  trozos
C        correspondientes  a  ciertas  restricciones  de  igualdad  y
C        desigualdad :
C
C          (1F) <(A(1,J),A(2,J),...,A(N,J)),X>  = B(J), J=1,MIF
C          (2F) <(A(1,J),A(2,J),...,A(N,J)),X> <= B(J), J=1+MIF,MIF+MDF
C
C        tomando la forma:
C
C               F(X)= ALFA*( 1/2*X'*H*X + P'*X ) +
C                    +( ABS(A'*X-B)) + ( MAX(A'*X-B,0))
C
C
C     LISTA DE LLAMADA:
C     DE ENTRADA:
C
C        A      Matriz de dimension  (IA,MIF+MDF).   En sus  N  primeras
C               filas contiene los coeficientes de las restricciones que
C               dan lugar a terminos (lineales a trozos) en el funcional
C               Los  de  igualdad  se  almacenan  en  las  MIF  primeras
C               columnas y los de desigualdad en el resto.
C
C        IA     Primera dimension de A. IA >= N.
C
C        C      Matriz  de  dimension  (IC,MI+MD).   En sus  N  primeras
C               filas  contiene  los  coeficientes  de  restricciones de
C               igualdad y desigualdad no presentes en el funcional. Los
C               de igualdad se almacenan en las  MI  primeras columnas y
C               los de desigualdad en las restantes.
C
C        IC     Primera dimension de C. IC >= N.
C
C        Q      Matriz de trabajo de dimension  (IQ,N). Si  MODO=-2  o
C               MODO= 0, 3  o  5, contiene la matriz ortogonal  de la
C               factorizacion  QR  de la matriz de coeficientes de las
C               restricciones  recomendadas  o  de  las  restricciones
C               activas.
C
C        IQ     Primera dimension de la matriz  Q. IQ >= N.
C
C        R      Matriz de  trabajo  de  dimension  (IR,N+1). En las  N
C               primeras columnas contiene  la matriz  H  del  termino
C               cuadratico.   Es  suficiente  suministrar  la  parte
C               triangular inferior. Si  MODO= -2  o  MODO= 0, 3  o  5
C               a partir de la segunda columna se suministra  la parte
C               no nula  de la matriz triangular    superior  de  la
C               factorizacion  QR  de  la  matriz  de coeficientes  de
C               las restricciones recomendadas o de las restricciones
C               activas.  El resto de la matriz se utiliza como area
C               de trabajo.
C
C        IR     Primera dimension de la matriz  R. IR >= N.
C
C        P      Vector  N-dimensional.  Contiene  los  coeficientes  del
C               termino lineal del funcional.
C
C        B      Vector de dimension  MIF+MDF. Contiene los coeficientes
C               de los terminos independientes de las restricciones que
C               originan terminos en el funcional.
C
C        D      Vector de dimension  MI+MD.  Contiene  los  coeficientes
C               de los  terminos  independientes  de  las  restricciones
C               de igualdad y desigualdad ajenas al funcional.
C
C        CI     Si  IRA= 0  o  2  esta  variable  no sera  utilizada. Si
C               IRA= 1  o  3,  CI   sera  un  vector  de  dimension   N
C               conteniendo  las  cotas  inferiores de  X.  Si  X(I)  no
C               esta acotado inferiormente,  CI(I)  debera ser menor que
C               la raiz  cuadrada  negativa  de la constante  real  mas
C               grande de la maquina.
C
C        CS     Si  IRA= 0  o  1  esta  variable  no sera  utilizada. Si
C               IRA= 2  o  3,  CS  sera  un  vector  de  dimension   N ,
C               conteniendo  las  cotas  superiores  de  X. Si  X(I)  no
C               esta acotado superiormente, CS(I)  debera ser mayor que
C               la raiz cuadrada  de la constante real mas grande  de la
C               maquina.
C
C        X      Vector N-dimensional. Si  MODO <> 1, 6 contiene un punto
C               admisible para las restricciones externas al funcional.
C
C        W      Vector de trabajo de dimension :
C                N1+MAX(N+MD,N2), si  MODO= 1, 6
C                N1+MAX(MI,N2), si  MODO= 0, -1, -2, 2, 4
C                N1+N2,  si  MODO= 3, 5
C               con
C                N1=2*N+MD
C                N2=N+MIF+MDF+MAX(2*N-2,MD+MIF+MDF)
C
C        IW     Indicador que toma los valores:
C                  1  : Se obtiene el valor del funcional  al final del
C                       proceso si en salida  IND=0.
C                  0  : No se obtiene tal valor.
C
C        IRE    Vector entero de dimension  N+MD+MIF+MDF. Este vector se
C               facilita si  MODO=  -2, -1, 0, 3  o  5.
C               -Si  MODO= 3  o  5, indica como son las restricciones al
C               comienzo del proceso, en la forma siguiente:
C                 Si  1 <= I <= N,
C                  IRE(I)=  0  : Restriccion  de  acotacion  que  se
C                                satisface estrictamente.
C                  IRE(I)= -1  : Cota inferior activa.
C                  IRE(I)=  1  : Cota superior activa.
C                 Si  N < I <= N+MD,
C                  IRE(I)=  0  : Restriccion  de  desigualdad  (ajena al
C                                funcional) satisfecha estrictamente.
C                  IRE(I)=  1  : Restriccion activa.
C                 Si  N+MD < I <= N+MD+MIF+MDF,
C                  IRE(I)=  0  : Restricion (asociada al funcional) que
C                                se satisface estrictamente.
C                  IRE(I)=  1  : Restriccion activa.
C                  IRE(I)=  2  : Restriccion violada  (a'x-b > 0).
C                  IRE(I)= -2  : Restriccion  ( de  igualdad )  violada
C                                (a'x-b < 0).
C               -Si   MODO < 1,   se   indica   que   restricciones   se
C               recomiendan como activas, en la forma siguiente:
C                 Si  1 <= I <= N,
C                  IRE(I)=  0  : Restriccion de acotacion no recomendada
C                  IRE(I)= -1  : Cota inferior activa.
C                  IRE(I)=  1  : Cota superior activa.
C                 Si  N < I <= N+MD+MIF+MDF,
C                  IRE(I)=  0  : Restriccion (de desigualdad  o asociada
C                                al funcional) no recomendada.
C                  IRE(I)=  1  : Restriccion recomendada como activa.
C
C        IPVT   Vector entero  de trabajo  de dimension:
C                M+MAX(MIF+MDF,1) ,  si  MODO= 3  o  5
C                N+MAX(MI+MD+1,MIF+MDF), en otro caso.
C               Si  MODO= -2, 0, 3  o  5, en las  M primeras coordenadas
C               indica las restricciones que son recomendadas o activas:
C                Si  1 <= I <= MI1,
C                 IPVT(I)=J      indica  que  la  i-esima  restriccion
C                                activa es la  j-esima de igualdad.
C                Si  MI1 < I <= M,
C                 IPVT(I) <= N :
C                                Indica que la restriccion i-esima es de
C                                acotacion  inferior  si  IPVT(I) < 0, o
C                                de acotacion superior si  IPVT(I) > 0.
C                 IPVT(I) <= N+MD :
C                                Hace referencia a la restriccion numero
C                                IPVT(I)-N de desigualdad
C                 IPVT(I) <= N+MD+MIF+MDF
C                                Indica la restriccion IPVT(I)-N-MD del
C                                funcional, (de igualdad si IPVT(I) <=
C                                N+MD+MIF o de desigualdad).
C
C        JPVT   Vector entero de trabajo de dimension:
C                  N-MI1      si  MODO= 3  o  5
C                  N          en otro caso.
C
C        ALFA   Coeficiente de penalizacion asociado al funcional.
C
C        IRA    Variable  que  indica  si  existen  restricciones  de
C               acotacion en el problema. Toma los valores:
C                  0  : No existen restricciones de acotacion.
C                  1  : Se  tienen  solo  restricciones  de  acotacion
C                       inferior.
C                  2  : Existen solo restricciones de acotacion superior
C                  3  : Se tienen ambos tipos de restriccion.
C
C        N      Numero de variables del problema.
C
C        M      Indica el numero de restricciones recomendadas o activas
C               del problema. Se facilita si  MODO= -2, 0, 3  o  5.
C
C        MI     Numero de restricciones de igualdad del problema (ajenas
C               al funcional).
C
C        MI1    Numero de restricciones de igualdad linealmente indepen-
C               dientes. Se facilita con los  MODOS  -2, 0, 3  y  5.
C
C        MD     Numero  de  restricciones  de desigualdad  del  problema
C               (ajenas al funcional).
C
C        MIF    Numero de restricciones de igualdad que pueden originar
C               terminos en el funcional.
C
C        MDF    Numero de restricciones de desigualdad presentes en el
C               funcional.
C
C        MODO   Variable que indica el modo de comienzo del proceso con
C               los valores:
C                 -2  : Se  facilita  un  punto  inicial,  restricciones
C                       recomendadas  como activas, la factorizacion  QR
C                       de la matriz  de coeficientes  de  restricciones
C                       recomendadas y la factorizacion de Cholesky  del
C                       hessiano proyectado.
C                 -1  : Se suministra un punto inicial y  se recomiendan
c                       como  activas algunas restricciones, pero no se
C                       facilita la factorizacion  QR.
C                  0  : Se  facilita  un punto inicial  y  restricciones
C                       recomendadas como activas y la factorizacion  QR
C                       de la matriz  de coeficientes  de  restricciones
C                       recomendadas.
C                  1  : No  se  suministra  ni  un  punto  inicial,  ni
C                       restricciones recomendadas, ni factorizacion QR.
C                  2  : Se facilita un punto inicial.
C                  3  : Se da un punto inicial y la factorizacion  QR de
C                       las restricciones activas.
C                  4  : Se suministra un vertice como punto inicial.
C                  5  : Se  da  un vertice  como punto  de partida  y la
C                       factorizacion  QR  de las restricciones activas.
C                  6  : Igual  que  MODO = 1,  pero la subrutina trabaja
C                       de forma diferente, (calcula  como punto inicial
C                       un vertice)
C
C               Si  MODO <> 1, 6   el  punto  suministrado  ha  de  ser
C               admisible para las restricciones externas al funcional.
C               El  caso  de  vertice,  mencionado  anteriormente,  esta
C               referido tambien a estas restricciones.
C
C        IMP    Indicador del nivel de impresion de salida de resultados
C               Toma los valores:
C                  6  : Sin salida de resultados.
C                  7  : Escribe el motivo de finalizacion del proceso.
C                  8  : Se obtiene informacion referente  a la solucion:
C                       el numero de iteraciones; el  optimo  calculado,
C                       la norma del vector de Kuhn-Tucker, el numero de
C                       restricciones  activas  y  cuales   son    (para
C                       identificar estas restricciones  se  sigue el
C                       siguiente convenio para  los  valores   que   se
C                       obtienen:
C
C                       [-N,-1]         : Restriciones de cota inferior
C                       [ 1,N ]         : Restricciones de cota superior
C                       [N+1,N+MI]      : Restricciones de igualdad
C                       [N+MI+1,N+MI+MD]: Restricciones de desigualdad)
C
C                       y los multiplicadores de  Lagrange  asociados  a
C                       ellas  (si IND=0);  el valor  del funcional  (si
C                       IND=0  con  IW=1  o  IND=-3); la norma del punto
C                       calculado (si  IND=-3).
C                  9  : Se obtiene  informacion referente  al desarrollo
C                       de las iteraciones:  el numero de  restricciones
C                       activas  y  cuales  son   (vector   IPVT),   las
C                       restricciones  asociadas  al  funcional  que  se
C                       violan (vector  IRE, si existen), la restriccion
C                       que se anade o elimina  del conjunto activo,  el
C                       tipo  de  direccion  de descenso calculada y las
C                       iteraciones con punto degenerado.
C               > 10  : Ademas,  se  obtiene  el punto calculado en cada
C                       iteracion e informacion sobre el proceso llevado
C                       a cabo por OPTR01. (Ver valores posibles de  IMP
C                       en  OPTR01).
C
C        IO     Numero de canal de salida de resultados.
C
C       ITER  : Numero maximo de iteraciones que realizara el proceso.
C               Si ITER <= 0, se usara el valor 14*(N+MI+MD+MIF+MDF).
C
C     DE SALIDA:
C
C        Q      Contiene la matriz  Q  ortogonal de la factorizacion  QR
C               de la matriz de coeficientes de restricciones activas.
C
C        R      En  R  se tiene  la matriz  triangular  superior  de  la
C               factorizacion  QR  ,(columnas  2  a  M+1).   La   parte
C               triangular inferior de las  N  primeras columnas  no se
C               ha modificado.
C
C        IRE    Indica de que tipo son las restricciones en el punto  X
C               obtenido. Los valores de  IRE  siguen el convenio citado
C               en la entrada.
C
C        IPVT   Indica, en sus M primeras coordenadas, las restricciones
C               linealmente independientes que son activas en el punto X
C               Los  valores  de  IPVT  siguen  el  convenio  citado  en
C               entrada.
C
C        X      Vector que contiene el optimo calculado (si IND=0)  o la
C               ultima aproximacion obtenida.
C
C        IW     Indica, si en entrada  IW=1, la coordenada de  W  donde
C               se encuentra el valor  del  funcional  en  el  optimo.
C               Si ademas  IMP >= 8,  en la coordenada  IW+1  de  W  se
C               almacena el valor de la norma del vector de Kuhn-Tucker.
C
C        M      Numero de restricciones activas en el punto  X.
C
C        IND    Variable que indica el motivo por el cual se finaliza el
C               proceso. Toma el valor:
C                  1  : Se ha superado  el limite  de iteraciones fijado
C                       por el programa.
C                  0  : Se ha finalizado el proceso sin problemas.
C                 -1  : El funcional no esta acotado inferiormente.
C                 -2  : Se  encuentra  un punto  degenerado  con ciclaje
C                       indefinido.
C                 -3  : Posible problema no acotado.  La distancia entre
C                       los puntos  de dos iteraciones  consecutivas  es
C                       "demasiado grande".
C                 -4  : Los datos suministrados son incorrectos.
C                -11  : Incompatibilidad en el sistema de restricciones
C                       de igualdad en  OPTR01.
C                -12  : No existen puntos admisibles en  OPTR01 para las
C                       restricciones ajenas al funcional.
C                -13  : Se encuentra  un punto  degenerado  con  ciclaje
C                       indefinido en  OPTR01.
C                -14  : Se  ha  realizado  el limite  de iteraciones  en
C                       OPTR01 sin encontrar un punto admisible para las
C                       restricciones ajenas al funcional.
C
C        ITER   Numero de iteraciones realizadas.
C
C
C        Esta subrutina trabaja en doble precision via una sentencia
C     "implicit":
C                Implicit double precision (a-h,o-z)
C
C     SUBPROGRAMAS AUXILIARES: anfm01,anfm02,anfm03,anfm04,anfm05,anfm06
C                anrs01,anrs02,auxo01,aux003,dadd,daxpy,dcopy,ddif,ddot,
C                desr03,dimp03,dipvtf,dmmul,dnrm0,dnrm2,dscal,dswap,
C                d1mach,idamax,nvkt03,optr01,opvf03,pasr03,tol03,zthz
C     FUNCIONES FORTRAN INTRINSECAS: abs,max,min,mod,sign,sqrt
C
C
      implicit double precision(a-h,o-z)
      dimension c(ic,*),a(ia,*),p(*),x(*),d(*),b(*),ci(*),cs(*),q(iq,*),
     &          r(ir,*),w(*),ire(*),ipvt(*),jpvt(*)
C
C     Se comprueba si los valores de las variables son correctos
C
      if((ic.lt.n.and.(mi.gt.0.or.md.gt.0)) .or. n.le.1 .or. ir.lt.n .or
     &   . ((mif.gt.0.or.mdf.gt.0).and.ia.lt.n) .or. iq.lt.n .or. modo.
     &   lt.-2 .or. modo.gt.6 .or. mi.lt.0 .or. md.lt.0 .or. mif.lt.0 .
     &   or. mdf.lt.0 .or. ira.lt.0 .or. ira.gt.3 .or. io.lt.1) then
         ind=-4
         call dimp03(x,w,ire,ipvt,s,0,0,0,0,0,0,0,0,0,ind,imp,
     &               io,iter)
         return
      end if
C
C     Se toman algunos parametros de trabajo
C
css      epsmch=d1mach(4)
      epsmch=dlamch('p')

      eps=epsmch**0.75
      eps0=epsmch**0.9
css      gigant=d1mach(2)
      gigant=dlamch('o')
      gig1=sqrt(gigant)
C
C     Se comprueba que los vectores  CI,CS,IRE toman valores correctos
C
      if(ira.gt.0) then
         do 10 i=1,n
            if(ira.eq.3) then
               if(ci(i).ge.-gig1 .and. cs(i).le.gig1 .and. ci(i).
     &            gt.cs(i)) then
                  if(imp.ge.7) call dimp03(x,w,ire,ipvt,s,i,0,0,0,0,
     &                                   0,0,0,0,-24,imp,io,iter)
                  ind=-4
                  return
               end if
            end if
            if(modo.eq.3 .or. modo.eq.5 .or. modo.le.0) then
               if(ire(i).lt.-1 .or. ire(i).gt.1) then
                  if(imp.ge.7) call dimp03(x,w,ire,ipvt,s,0,0,0,0,
     &                                0,0,0,0,0,-34,imp,io,iter)
                  ind=-4
                  return
               end if
            end if
10       continue
      end if
      if(modo.eq.3 .or. modo.eq.5 .or. modo.le.0) then
         do 20 i=n+1,n+md+mif+mdf
            if(((ire(i).lt.0 .or. ire(i).gt.1) .and. i.le.n+md) .or.
     &         ((ire(i).lt.-2 .or. ire(i).gt.2) .and. i.gt.n+md)) then
               if(imp.ge.7) call dimp03(x,w,ire,ipvt,s,0,0,0,0,0,
     &                                  0,0,0,0,-34,imp,io,iter)
               ind=-4
               return
            end if
20       continue
      end if
C
C     Se inicializan algunas variables enteras de trabajo
C
      if(modo.gt.3) then
         iver=1
         if(modo.eq.6) then
            modo=1
         else
            modo=modo-2
         end if
      else
         iver=-1
      end if
      n1=n+1
      n2=n1+n
      n3=n2+n
      n10=10*iq
      if(modo.ne.3 .or. modo.ne.0) mi1=mi
      mid=mi+md
      midf=mif+mdf
      nmd=n+md
      nmdi=nmd+mif
      nd1=nmd+1
      nd=nmd+midf+1
      icd=nd+n
      iad=icd+md
      idw=iad+midf
      id=0
      ind=0
      icicla=0
      il=0
      icol=0
      icol1=0
      icol2=0
      iicol=0
      info=0
      if (iter.le. 0) then
          itemax=14*(n+mid+midf)
      else
          itemax=iter
      end if
      iter=0
      icont=0
      if(ira.eq.0) then
         do 30 i=1,n
30       ire(i)=0
      end if
C
C     Si se han recomendado activas ciertas restricciones y no se ha
C     suministrado la factorizacion  QR , (MODO=-1), se procede a su
C     calculo
C
      if(modo.eq.-1) then
         if(mi.eq.0) m=0
         if(mid.eq.0) then
            do 34 i=1,n
               do 32 j=1,n
                  if(i.eq.j) then
                     q(i,j)=1
                  else
                     q(i,j)=0
                  end if
32             continue
34          continue
         end if
         if(mid.eq.0 .and. ira.gt.0) then
            do 36 i=1,n
               if(ire(i).eq.1) ind=i
               if(ire(i).eq.-1) ind=-i
               if(ind.ne.0) then
                  m=m+1
                  call anfm01(q,iq,r(1,2),ir,w,w,n,m,ind,io)
                  ipvt(m)=ire(i)*i
               end if
36          continue
         else if(mid.gt.0) then
            modo=22
            call optr01(c,ic,q,iq,r(1,2),ir,ci,cs,d,x,w,ipvt,ire,ira,n,
     &                  m,mi,mi1,md,ind,imp,io,modo)
            modo=-1
         end if
         if(midf.gt.0) then
            i=1
            if(i.le.midf .and. m.lt.n) then
 1000          ni=nmd+i
               if(ire(ni).eq.1) then
                  m1=m+1
                  ind=0
                  call anfm01(q,iq,r(1,2),ir,a(1,i),w,n,m1,ind,io)
                  if(ind.lt.0) then
                     ire(ni)=0
                  else
                     m=m1
                     ipvt(m)=ni
                  end if
               end if
               i=i+1
               if(i.le.midf .and. m.lt.n) go to 1000
            end if
         end if
      end if
C
C     Si  se  han  recomendado  restricciones  activas, (MODO <= 0), se
C     proyecta el punto suministrado sobre la variedad de restricciones
C     recomendadas
C
      if(modo.le.0) then
         i1=idamax(n,x,1)
         s1=x(i1)
         if(s1.eq.0.d0) then
            do 38 i=1,mi1
38          w(i)=d(ipvt(i))
            do 40 i=mi1+1,m
               l=ipvt(i)
               if(l.lt.0) then
                  w(i)=-ci(-l)
               else if(l.le.n) then
                  w(i)=cs(l)
               else if(l.le.nmd) then
                  w(i)=d(mi+l-n)
               else
                  w(i)=b(l-nmd)
               end if
40          continue
         else
            do 42 i=1,mi1
               l=ipvt(i)
               w(i)=d(l)-ddot(n,c(1,l),1,x,1)
42          continue
            do 44 i=mi1+1,m
               l=ipvt(i)
               if(l.lt.0) then
                  w(i)=-ci(-l)+x(-l)
               else if(l.le.n) then
                  w(i)=cs(l)-x(l)
               else if(l.le.nmd) then
                  ni=mi+l-n
                  w(i)=d(ni)-ddot(n,c(1,ni),1,x,1)
               else
                  ni=l-nmd
                  w(i)=b(ni)-ddot(n,a(1,ni),1,x,1)
               end if
44          continue
         end if
         ind=1
         call anrs01(r(1,2),ir,m,w,w(n1),ind,io)
         ind=0
         call dmmul(q,iq,w(n1),m,w,n,n,m,1)
         call dadd(n,x,1,w,1)
C
C     Se  verifica  si  el  punto  obtenido  al  proyectar  cumple  las
C     restricciones no activas  y  ajenas al funcional;  recomenzando el
C     proceso  (con  MODO=2) si el resultado es negativo
C
         iv=0
         if(mid.gt.0 .or. ira.gt.0) then
            i1=mi+1
            call auxo01(c(1,i1),ic,ci,cs,d(i1),w,w(n1),ire,ira,n,md,ind,
     &                  fun,iv)
         end if
         if(iv.eq.0) then
            call dcopy(n,w,1,x,1)
         else
            modo=2
         end if
      end if
C
C     Si no existe factorizacion  QR  de las restricciones activas, ni
C     restricciones de igualdad o desigualdad fuera del funcional, se
C     inicializan la matriz  Q   (MODO= 1 o 2)
C
      if(mid.eq.0 .and. (modo.eq.2 .or. (modo.eq.1 .and. ira.eq.0)))then
         m=0
         do 60 i=1,n
            do 50 j=1,n
               if(i.eq.j) then
                  q(i,j)=1
               else
                  q(i,j)=0
               end if
50          continue
60       continue
      end if
C
C     Si  no  se  da  un  punto  inicial, (modo=1), se calcula  un punto
C     admisible junto con la factorizacion  QR  de las  correspondientes
C     restricciones activas y los vectores  ire  e  ipvt.
C
      if(modo.eq.1) then
         do 70 i=1,n
70       x(i)=0
         if(mid.gt.0 .or. ira.gt.0) then
            if(iver.eq.1) modo=11
            call optr01(c,ic,q,iq,r(1,2),ir,ci,cs,d,x,w,ipvt,ire,ira,n,
     &                  m,mi,mi1,md,ind,imp,io,modo)
            if(iver.eq.1) modo=1
            if(ind.lt.0) then
               ind=ind-10
               if(imp.ge.7 .and.imp.le.10) call dimp03(x,w,ire,ipvt,s,0
     &                         ,0,0,0,0,0,0,0,0,ind,imp,io,iter)
               return
            end if
            call dcopy(md,w(n3),1,w(n1),1)
         end if
      end if
C
C     Se calcula la factorizacion  QR  de las restricciones activas en
C     caso de suministrarse un punto inicial (modo=2)
C
      if(modo.eq.2) then
         m=0
         if(ira.ge.1) then
            do 90 i=1,n
               ire(i)=0
               if(ira.ne.2) then
                  if(ci(i).ge.-gig1) then
                     if(x(i).lt.(ci(i)+eps)) then
                        x(i)=ci(i)
                        ire(i)=-1
                        if(mid.eq.0) then
                           m=m+1
                           ip=-i
                           call anfm01(q,iq,r(1,2),ir,x,w,n,m,ip,io)
                           ipvt(m)=-i
                        end if
                     end if
                  end if
               end if
               if(ira.ge.2) then
                  if(cs(i).le.gig1 .and. ire(i).eq.0) then
                     if(x(i).gt.(cs(i)-eps)) then
                        x(i)=cs(i)
                        ire(i)=1
                        if(mid.eq.0) then
                           m=m+1
                           ip=i
                           call anfm01(q,iq,r(1,2),ir,x,w,n,m,ip,io)
                           ipvt(m)=i
                         end if
                     end if
                  end if
               end if
90          continue
         end if
         do 100 i=1,md
            ii=mi+i
            s=ddot(n,c(1,ii),1,x,1)-d(ii)
            ni=n+i
            if(s.gt.-eps) then
               ire(ni)=1
            else
               ire(ni)=0
            end if
            w(ni)=s
100      continue
         if(mid.gt.0) then
            modo=22
            call optr01(c,ic,q,iq,r(1,2),ir,ci,cs,d,x,w(nd1),ipvt,ire,
     &                  ira,n,m,mi,mi1,md,ind,imp,io,modo)
            modo=2
         end if
      end if
      iv=0
      if(iver.eq.1) then
         iv=m
         iver=m
      end if
C
C     Se calcula el vector  IRE  asociado a las restricciones presentes
C     en el funcional (si MODO <= 2)
C
      if(modo.eq.3) then
         do 110 i=1,md
            ii=mi+i
            ni=n+i
            w(ni)=0
            if(ire(ni).eq.0) w(ni)=ddot(n,c(1,ii),1,x,1)-d(ii)
110      continue
         do 120 i=1,midf
            ii=abs(ire(nmd+i))
            if((i.le.mif .and. ii.eq.2) .or. (ii.ne.1)) then
               w(nmd+i)=ddot(n,a(1,i),1,x,1)-b(i)
            else
               w(nmd+i)=0
            end if
120      continue
      else
         do 130 i=1,midf
130      w(nmd+i)=0
         ind=0
         if(modo.gt.0) then
            do 140 i=nd1,nmd+midf
140         ire(i)=0
         end if
         call aux003(a,ia,x,b,q,iq,r(1,2),ir,w(nd1),ire(nd1),ipvt,nmd,
     &               mif,mdf,midf,n,m,ind,io)
      end if
      if(m.eq.n) then
         minimo=1
         id=2
         nm=0
      else
         minimo=0
      end if
C
C     Se calcula la matriz  Z'HZ  y se factoriza
C
      if(minimo.eq.0 .and. modo.ne.-2) then
         m1=m+1
         nm=n-m
         ind=0
         call anfm03(r,ir,r(1,m1+1),ir,q(1,m1),iq,w,jpvt,n,nm,ind,
     &               iver-iv,io)
         if(ind.le.-n10) then
            ind=ind+n10
            iibeta=1
         else
            iibeta=0
         end if
         if(ind.eq.n .and. iver.eq.iv) then
            ind=-1
            if(imp.ge.7) call dimp03(x,w,ire,ipvt,s,0,0,0,0,0,
     &                               0,0,0,0,ind,imp,io,iter)
            return
         end if
      else if(minimo.eq.0) then
         nm=n-m
      end if
C
C     Comienzan las iteraciones
C
      if(iter.le.itemax) then
2000     iadd=0
         ind1=0
         il=0
         inddes=0
         if(iicol.eq.1) id=2
C
C     Se calcula el gradiente del funcional si no hay ciclaje
C
         if(icicla.eq.0) then
            do 160 i=1,n
               i1=i+1
               s=ddot(i,r(i,1),ir,x,1)
               if(i.lt.n) w(i)=s+ddot(n-i,r(i1,i),1,x(i1),1)
160         continue
            w(n)=s
            call dadd(n,p,1,w,1)
            if(alfa.ne.1.d0) call dscal(n,alfa,w,1)
            do 180 i=1,mif
               ni=nmd+i
               if(ire(ni).eq.2) then
                  call dadd(n,a(1,i),1,w,1)
               else if(ire(ni).eq.-2) then
                  call ddif(n,a(1,i),1,w,1)
               end if
180         continue
            do 190 i=mif+1,midf
190         if(ire(i+nmd).eq.2) call dadd(n,a(1,i),1,w,1)
         end if
C
C     Se calculan los multiplicadores de Lagrange si el paso dado en la
C     iteracion anterior conduce a un punto estacionario (id=2 o id=3)
C     y si se verifica el test sobre el gradiente proyectado
C
         s1=gigant
         s2=0
         if(id.ge.2) then
            i1=icd-1
            do 200 i=1,nm
200         w(i1+i)=ddot(n,q(1,n1-i),1,w,1)
            if(minimo.eq.0) s2=dnrm2(nm,w(icd),1)/(1+dnrm0(n,w,1))
            if(s2.ge.eps0) then
               info=10
               icont=icont+1
            else if(icont.gt.0) then
               icont=0
            end if
            if((m.gt.mi1 .or. ((imp.ge.8 .or. iw.eq.1) .and. m.gt.0))
     &         .and. (icont.eq.0 .or. icont.eq.3)) then
               do 220 i=1,m
220            w(nd+i-1)=-ddot(n,q(1,i),1,w,1)
               call anrs01(r(1,2),ir,m,w(nd),w(nd),2,io)
               if(m.gt.mi1) then
C
C     Se verifica si son correctos los valores de los multiplicadores
C     de Lagrange
C
                  icol=0
                  j=nd-1+mi1
                  do 230 i=mi1+1,m
                     j=j+1
                     k=ipvt(i)
                     if(k.le.nmd) then
                        s=w(j)
                     else if(k.gt.nmd .and. k.le.nmdi) then
                        s=1.d0-abs(w(j))
                     else
                        sw=w(j)
                        s=min(sw,1.d0-sw)
                     end if
                     if(s.lt.s1) then
                        s1=s
                        icol=i
                     end if
230               continue
                  if(s1.le.eps) then
                     if(s1.ge.-eps) call dcopy(m,w(nd),1,w(icd),1)
                     if(icont.gt.0) icont=0
C
C     Se elimina del conjunto activo la restriccion correspondiente a la
C     columna  ICOL  y se modifican la factorizacion  QR correspondiente
C     a las restricciones activas  y  la factorizacion de Cholesky de la
C     matriz  Z'HZ.
C
                     if(m.gt.1) call anfm02(q,iq,r(1,2),ir,n,m,icol,io)
                     m1=m-1
                     il=ipvt(icol)
                     if(il.gt.n) w(il)=0
                     s=w(nd+icol-1)
                     ire(abs(il))=0
                     do 240 j=icol,m1
240                  ipvt(j)=ipvt(j+1)
                     if(minimo.eq.1) then
                        ind=0
                        nm=0
                     end if
                     call anfm06(q(1,m),iq,r,ir,w(nd),jpvt,n,nm,ind,io)
                     info=1
                     m=m1
                     if(iver.ne.-1 .and. il.le.nmd) then
                        iver=iver-1
                     else if(iver.eq.iv .and. ind.lt.0) then
                        ind=-1
                        if(imp.ge.7) call dimp03(x,w,ire,ipvt,s,0,
     &                      0,0,0,0,0,0,0,0,ind,imp,io,iter)
                        return
                     end if
                  end if
                  if(abs(s1).le.eps) then
                     if(ind.ge.0 .and. ind.le.nm) then
                        call dcopy(icol-1,w(icd),1,w(nd),1)
                        j1=nd+icol-1
                        do 243 j=icd+icol,icd+m
                           w(j1)=w(j)
                           j1=j1+1
 243                    continue
                        if(abs(s).gt.eps) then
                           w(nd+m)=s
                           m=m+1
                           ipvt(m)=il
                           ire(il)=1
                           ip=0
                           call anfm04(q,iq,r(1,2),ir,a(1,il-nmd),
     &                                 w(icd),jpvt,n,m,ip,io)
                        end if
                     else
                        if(abs(s-1.d0).le.eps) then
                           inddes=-il
                        else
                           inddes=il
                        end if
                     end if
                  end if
               end if
            end if
         end if
C
C     Impresion de los resultados obtenidos si x es un minimo local
C
         if(id.ge.2 .and. (s1.ge.-eps.and.inddes.eq.0) .and.
     &      (s2.lt.eps0 .or. icont.ge.3)) then
            call tol03(q,iq,r(1,2),ir,c,ic,d,a,ia,b,ci,cs,x,w(nd+m),
     &                 ipvt,n,m,mi,mi1,nmd,io)
            ind=0
            if(iw.ne.0) then
               iw=nd+m
               w(iw)=opvf03(r,ir,a,ia,p,b,x,w,alfa,nd,n,mif,mdf)
            end if
            if(imp.ge.8) then
               if(iw.ne.0) s=w(iw)
               call nvkt03(a,ia,c,ic,w,w(nd),w(nd+m),ipvt,dnorma,n,m,
     &                     mi1,mi,nmd,nd)
               if(iw.ne.0) then
                  w(iw)=s
                  w(iw+1)=dnorma
               end if
            end if
            if(imp.ge.7) call dimp03(x,w,ire,ipvt,dnorma,n,m,nd,iw,il,
     &                               0,0,mi,mi1,ind,imp,io,iter)
            return
         end if
C
C     Si  se  ha  eliminado  una  restriccion  asociada  al  funcional
C     se modifica el vector gradiente calculado
C
         if(il.gt.nmd) then
            k=il-nmd
            if(s.gt.0.d0) then
               call dadd(n,a(1,k),1,w,1)
            else if(s.lt.0.d0 .and. il.le.nmdi) then
               call ddif(n,a(1,k),1,w,1)
            end if
         end if
C     Se calcula una direccion de descenso
C
         m1=m+1
         m2=m1+1
         if(abs(inddes).le.n) then
            call desr03(q(1,m1),iq,r(1,m2),ir,w,w,w(icd),
     &               w(nd),jpvt,alfa,nm,n,ind,info,inddes,ro,io)
         else if(inddes.gt.n .and. inddes.le.nmd) then
            call desr03(q(1,m1),iq,r(1,m2),ir,w,c(1,mi+il-n),w(icd),
     &             w(nd),jpvt,alfa,nm,n,ind,info,inddes,ro,io)
         else
            call desr03(q(1,m1),iq,r(1,m2),ir,w,a(1,il-nmd),w(icd),
     &             w(nd),jpvt,alfa,nm,n,ind,info,inddes,ro,io)
         end if
         id=inddes
         if(imp.ge.9) then
            if(id.eq.1) then
               ides=1
            else if(ind.gt.0 .and. ind.le.nm)then
               ides=0
            else
               ides=-1
            end if
         end if
C
C     Se averigua si estamos ante un punto degenerado
C
         k=0
         if(iver.eq.-1 .or. iver.ne.iv) then
            if(ira.gt.0) then
               i=0
               if(i.lt.n .and. k.eq.0) then
4000             i1=i+1
                  ii=i+nd
                  xi1=x(i1)
                  if(ira.gt.1) then
                     csi=cs(i1)
                     if(csi.le.gig1 .and. ire(i1).eq.0 .and. w(ii)
     &                  .gt.eps .and. (xi1.ge.(csi-eps)))then
                        s2=dnrm2(nm,q(i1,m1),iq)
C modified 15-july-2005 (anfm04 uses and used eps0 but here we used: if(s2.ge.epsmch) then.
                        if(s2.ge.eps0) then
                           k=1
                           ipvt(m1)=i1
                        else
                           w(ii)=0
                        end if
                     end if
                  end if
                  if(k.eq.0 .and. ira.ne.2) then
                     cii=ci(i1)
                     if(cii.ge.-gig1 .and. ire(i1).eq.0 .and. w(ii
     &                  ).lt.-eps .and. (xi1.le.cii+eps))then
                        s2=dnrm2(nm,q(i1,m1),iq)
C modified 15-july-2005 (anfm04 uses and used eps0 but here we used: if(s2.ge.epsmch) then.
                        if(s2.ge.eps0) then
                           k=1
                           ipvt(m1)=-i1
                        else
                           w(ii)=0
                        end if
                     end if
                  end if
                  i=i1
                  if(i.lt.n .and. k.eq.0) go to 4000
               end if
            end if
            i=0
            if(i.lt.md .and. k.eq.0) then
5000           ii=icd+i
               i=i+1
               ni=n+i
               if(ire(ni).ne.1) then
                  w(ii)=ddot(n,c(1,mi+i),1,w(nd),1)
                  if(w(ni).ge.-eps .and. w(ii).gt.eps) then
                     jj=idw
                     do 245 j=m1,n
                        w(jj)=ddot(n,q(1,j),1,c(1,mi+i),1)
                        jj=jj+1
245                  continue
                     s2=dnrm2(nm,w(idw),1)
C modified 15-july-2005 (anfm04 uses and used eps0 but here we used: if(s2.ge.epsmch) then.

                     if(s2.ge.eps0) then
                        k=1
                        ipvt(m1)=ni
                     else
                        w(ii)=0
                     end if
                  end if
               end if
               if(i.lt.md .and. k.eq.0) go to 5000
            end if
         else
            do 250 i=icd,icd+md-1
250         w(i)=0
         end if
         i=0
         if(i.lt.midf .and. k.eq.0) then
6000        i1=i+1
            in=nmd+i1
            if(ire(in).ne.1 ) then
               ii=iad+i
               w(ii)=ddot(n,a(1,i1),1,w(nd),1)
               if(ire(in).eq.0 .and. in.ne.il) then
                  if((i1.le.mif.and.abs(w(ii)).gt.eps) .or.
     &               (i1.gt.mif.and.w(ii).gt.eps.and.w(in).ge.-eps
     &               )) then
C
C     Se averigua si la restriccion que origina un punto degenerado es
C     linealmente dependiente de las restricciones que formaban el
C     conjunto activo al comienzo de la iteracion
C
                     if(il.eq.0) then
                        m0=m1
                     else
                        m0=m+2
                     end if
                     jj=idw
                     do 260 i=m0,n
                        w(jj)=ddot(n,q(1,i),1,a(1,i1),1)
                        jj=jj+1
260                  continue
                     s2=dnrm2(nm,w(idw),1)
C
C     Si la restriccion no es linealmente dependiente se apade al
C     conjunto activo y si no, se averigua si existe direccion de
C     descenso violandose esa restriccion
C
C modified 15-july-2005 (anfm04 uses and used eps0 but here we used: if(s2.ge.epsmch) then.

                     if(s2.ge.eps0) then
                        k=1
                        ipvt(m1)=in
                     else if(il.eq.0) then
                        w(ii)=0
                     else
                        sj=ddot(n,q(1,m1),1,a(1,i1),1)
                        if(abs(sj).ge.epsmch) then
                           if(id.ne.1) ind1=10
                           if(il.lt.0) then
                              sj=-sj/q(-il,m1)
                           else if(il.le.n) then
                              sj=sj/q(il,m1)
                           else if(il.le.nmd) then
                              s2=ddot(n,q(1,m1),1,c(1,mi+il-n),1)
                              sj=sj/s2
                           else
                              s2=ddot(n,q(1,m1),1,a(1,il-nmd),1)
                              sj=sj/s2
                           end if
                           sk=0.d0
                           s3=-1.d0
                           if(i1.le.mif) then
                              s2=abs(sj)
                              if(il.le.nmd .or. (il.gt.nmdi.and.s.lt.
     &                           -eps)) then
                                 s3=s2+s
                                 if(sj.gt.eps) then
                                    sk=-1.d0
                                 else
                                    sk=1.d0
                                 end if
                              else
                                 s3=s2-abs(s)+1.d0
                                 if((s.lt.-eps.and. sj.gt.eps) .or.
     &                              (s.gt.eps.and. sj.lt.-eps)) then
                                    sk=-1.d0
                                 else
                                    sk=1.d0
                                 end if
                              end if
                           else
                              if(sj.lt.-eps .and. (il.le.nmd.or.
     &                           (il.gt.nmdi.and.s.lt.-eps))) then
                                 s3=s-sj
                                 sk=1.d0
                              else if(sj.gt.eps .and. il.gt.nmd .and.
     &                           s.gt.eps) then
                                 s3=sj+s1
                                 sk=1.d0
                              else if(sj.lt.-eps .and. il.gt.nmd .and.
     &                           il.le.nmdi .and. s.lt.-eps) then
                                 s3=s1-sj
                                 sk=1.d0
                              end if
                           end if
                           if(s3.gt.eps) then
                              ipvt(m1)=nmd+i1
                              if(id.eq.1) then
                                 id=2
                                 k=1
                              else
                                 ind1=11
                              end if
                           else if(id.eq.1) then
C
C     Se modifican la direccion de descenso o el paso calculado, y el
C     vector gradiente
C
                              if(s.gt.0.d0) then
                                 s1=-s+1
                              else if(s.lt.0.d0.and.il.le.nmdi.and.il
     &                           .gt.nmd) then
                                 s1=-s-1
                              else
                                 s1=-s
                              end if
                              s=1.d0+(sk*sj)/s1
                              if(info.eq.0) then
                                 call dscal(n,s,w(nd),1)
                              else
                                 ro=s*ro
                              end if
                              if(sk.eq.1.d0) then
                                 call dadd(n,a(1,i1),1,w,1)
                              else if(sk.eq.-1.d0) then
                                 call ddif(n,a(1,i1),1,w,1)
                              end if
                              w(ii)=0.d0
                           end if
                        else
                           w(ii)=0
                        end if
                     end if
                  end if
               end if
            end if
            i=i1
            if(i.lt.midf .and. k.eq.0) go to 6000
         end if
C
C     Calculo del paso en la direccion de descenso
C
         if(k.eq.0) then
            if(id.eq.0 .and. ind.le.nm .and. ind.gt.0) id=2
            if(ind1.eq.11 .and. id.ne.1) id=id+100
            if(ind1.eq.10 .and. id.ne.1) id=id+10
            call pasr03(a,ia,b,ci,cs,x,ro,w,ire,ipvt(m1),ira,n,md,mif,
     &                  mdf,m,id,io)
            if(id.eq.-1) then
               ind=-1
               if(imp.ge.7) call dimp03(x,w,ire,ipvt,s,0,0,0,0,0,
     &                                  0,0,0,0,ind,imp,io,iter)
               return
            else if(id.eq.0) then
               id=2
               k=1
            end if
            if(id.eq.1 .or. id.eq.3 .or. id.eq.11)then
               icol3=ipvt(m1)
               if(imp.ge.9) iadd=icol3
            end if
         end if
C
C     En caso de punto degenerado se estudia si se produce alternancia
C     entre las restricciones
C
         if(k.eq.1) then
            icicla=icicla+1
            icol3=ipvt(m1)
            if(imp.ge.9) iadd=icol3
            if((icicla.gt.m .and. m.gt.0).or.
     &         (icol3.eq.icol1 .and. icol.eq.m)) then
               ind=-2
               if(imp.ge.7) call dimp03(x,w,ire,ipvt,s,0,0,0,0,0,
     &                                 0,0,0,0,ind,imp,io,iter)
               return
            end if
            icol1=icol2
            icol2=icol3
         else if(icicla.gt.0) then
            icicla=0
            icol1=0
            icol2=0
         end if
C
C     Impresion de los datos correspondientes a la iteracion corriente
C
         if(imp.ge.9) call dimp03(x,w,ire(nd1),ipvt,s,n,il,m,midf,ides,
     &                           icicla,iadd,mi,mi1,2,imp,io,iter)
C
C     Calculo del punto de la iteracion siguiente
C
         if(icicla.eq.0) then
            i1=icd-1
            do 270 i=1,md
               ni=n+i
               if(ire(ni).eq.0 .and. (iver.ne.iv .or. iver.eq.-1) .and.
     &         id.lt.10)then
                  if(ro.eq.1.d0) then
                     w(ni)=w(ni)+w(i1+i)
                  else
                     w(ni)=w(ni)+ro*w(i1+i)
                  end if
               end if
270         continue
            if(ro.eq.1.d0) then
               call dadd(n,w(nd),1,x,1)
            else
               call daxpy(n,ro,w(nd),1,x,1)
            end if
            i1=nd-1
         end if
C
C     Se anade la restriccion  icol3  al conjunto activo y se modifica
C     el vector ire y la factorizacion  QR
C
         if(icicla.ne.0 .or. id.eq.1 .or. id.eq.11 .or. id.eq.3) then
            if(il.eq.-icol3) then
               iicol=1
            else
               iicol=0
            end if
            s=r(1,m2)
            nm1=nm-1
            m=m1
            if(icol3.lt.0) then
               ire(-icol3)=-1
            else
               ire(icol3)=1
            end if
            if(icol3.le.n) then
               ip=icol3
               call anfm04(q,iq,r(1,2),ir,w,w(nd),jpvt,n,m,ip,io)
            else
               ip=0
               if(icol3.le.nmd) then
                  call anfm04(q,iq,r(1,2),ir,c(1,mi+icol3-n),w(nd),jpvt,
     &                        n,m,ip,io)
               else
                  call anfm04(q,iq,r(1,2),ir,a(1,icol3-nmd),w(nd),jpvt,
     &                        n,m,ip,io)
               end if
            end if
C
C      Se modifica la factorizacion de Cholesky de la matriz  Z'HZ
C
            if(icol3.le.nmd .and. iver.ne.-1) iver=iver+1
            if(nm.gt.1) then
               if(iibeta.eq.1 .and. ind.eq.-2) ind=-1
               if(ind.gt.2*nm .and. ind.lt.3*nm) then
                  nf=3*nm-ind
               else if(ind.gt.nm .and. ind.lt.2*nm) then
                  nf=2*nm-ind
               else if(ind.lt.-1 .and. ind.ge.-nm) then
                  nf=-ind-1
               else if(ind.eq.-1 .or. ind.eq.(-nm-1) .or. ind.eq.3*nm
     &                 .or. ind.eq.2*nm) then
                  ind=0
                  call anfm03(r,ir,r(1,m+2),ir,q(1,m+1),iq,w(nd),jpvt,n,
     &                        nm1,ind,iver-iv,io)
                  nf=0
               else if(ind.ge.0) then
                  nf=nm
               else
                  nf=-nm-ind-1
               end if
               if(nf.ne.0) then
                  nmf=nm1-nf
                  if(ind.gt.nm) then
                     ii=nmf+i1
                  else if(ind.lt.0) then
                     ii=nmf*(nmf+1)/2+i1
                  end if
                  if(iibeta.eq.1) nf=nf-1
                  call anfm05(r,ir,r(1,m+2),ir,q(1,m+1),iq,w(nd),
     &                       w(nd+2*nm1),jpvt,s,nm1,nf,n,ind,iver-iv,io)
               end if
               if(ind.le.-n10) then
                  iibeta=1
                  ind=ind+n10
               else
                  iibeta=0
               end if
               if(ind.eq.n) then
                  ind=-1
                  if(imp.ge.7) call dimp03(x,w,ire,ipvt,s,0,0,0,0,
     &                                  0,0,0,0,0,ind,imp,io,iter)
                  return
               end if
               nm=nm1
            end if
         end if
C
C     Si x no es un punto degenerado se modifica el vector  IRE  de las
C     restricciones que aparecen en el funcional
C
         if(icicla.eq.0 .and. midf.gt.0) then
            i1=1
            call aux003(a,ia,x,b,q,iq,r(1,2),ir,w(nd1),ire(nd1),ipvt,
     &                  nmd,mif,mdf,midf,n,m,i1,io)
            if(i1.eq.0) info=0
         end if
         if(info.eq.1 .and. id.ne.2) then
            if(jpvt(nm).ne.nm .or. (ind.lt.0 .and. ind.ne.-n .and.
     &      ind.ne.(-2*n+1)) .or. ind.gt.n) info=0
         end if
C
C     Si el paso ha sido "demasiado grande", se calcula la norma y el
C     valor del funcional en el punto obtenido,  antes de regresar al
C     al subprograma de llamada
C
         if(id.eq.11) then
            iw=nd+m
            w(iw)=opvf03(r,ir,a,ia,p,b,x,w,alfa,nd,n,mif,mdf)
            ind=-3
            if(imp.ge.7) call dimp03(x,w,ire,ipvt,s,n,iw,0,0,0,0,
     &                               0,0,0,ind,imp,io,iter)
            return
         end if
         if(m.eq.n) then
            minimo=1
            id=2
            nm=0
         else
            minimo=0
         end if
         iter=iter+1
         if(iter.le.itemax) go to 2000
      end if
      ind=1
      if(imp.ge.7) call dimp03(x,w,ire,ipvt,s,il,ides,0,0,0,0,0,
     &                         0,0,ind,imp,io,iter)
      end


       subroutine  grad(nmax,nequ,nterm,itmax,ia,ja,coef,prec,
     1                  tnoto,tol,xnew,rmax)
C
C
       implicit none
       integer nequ,nterm,itmax,nmax
       integer i, iter
       integer ia(nequ+1), ja(nterm)

       real*8  coef(nterm), prec(nterm)
       real*8  tnoto(nequ), xold(nequ), xnew(nequ)
       real*8  rold(nequ), rnew(nequ)
       real*8  pold(nequ), pnew(nequ)
       real*8  hr(nequ),hp(nequ)
       real*8  kh(nequ),h_res(nequ), rmax

       real*8  tol,resnorm,norma,vettvett,norma1,norma2
       real*8  alpha, beta,nrm

       call lsolve(nequ,nterm,ia,ja,prec,tnoto,xold)
       call matvett(nmax,nequ,nterm,ia,ja,coef,xold,rold)
       do i=1,nequ
         rold(i)=tnoto(i) -rold(i)
       end do
       call lsolve(nequ,nterm,ia,ja,prec,rold,pold)
       iter=0
       resnorm=2*tol
       write(98,*) 'CONVERGENZA DEL GCM'
       do while ((iter.lt.itmax).and.(resnorm.ge.tol))
         iter = iter+1
         alpha= vettvett(nequ,pold,rold)
         call matvett(nmax,nequ,nterm,ia,ja,coef,pold,hp)
         alpha=alpha/vettvett(nequ,pold,hp)
         do i=1,nequ
              rnew(i)=rold(i) -alpha*hp(i)
         end do
         call lsolve(nequ,nterm,ia,ja,prec,hp,kh)
         beta=-vettvett(nequ,rnew,kh)/vettvett(nequ,pold,hp)
         call lsolve(nequ,nterm,ia,ja,prec,rnew,h_res)
         do i=1,nequ
            pnew(i) =h_res(i) +beta*pold(i)
            xnew(i)= xold(i) +alpha*pold(i)
         end do
         resnorm=norma2(nequ,rnew)/norma2(nequ,tnoto)*(1.e-09*rmax)
c        resnorm=norma2(nequ,rnew)/norma2(nequ,tnoto)
         write(98,101) iter, resnorm
 101     FORMAT(1x,'ITER:  ',I5,2x,'RESIDUO:  ',E16.5)
         do i=1,nequ
            pold(i) = pnew(i)
            xold(i) = xnew(i)
            rold(i) = rnew(i)
         end do
      end do
c     call matvett(nmax,nequ,nterm,ia,ja,coef,xnew,rnew)
c     do i=1,nequ
c          rnew(i)=tnoto(i)-rnew(i)
c     end do
c     resnorm=norma(nequ,rnew)/norma(nequ,tnoto)
c     write(*,*) 'residuo vero', resnorm

      return
      end


module fcm

use mpi
use settings
use partitioner, only: mesh,m
implicit none

! Delta function = (2*pi*sigma**2)^(-3/2) * exp( (x-Yn)**2/(2*sigma**2) )
! to be calculated once at each timestep for all particles
double precision, dimension(:,:,:,:), allocatable :: delta_fn

contains

subroutine calc_delta_fn(Yp)
    implicit none
    double precision, dimension(Np,3) :: Yp
    double precision :: temp2
    double precision, dimension(nz,ny,m) :: dist_sqr, temp1
    double precision :: sigma
    integer :: i

    if (.not. allocated(delta_fn)) allocate(delta_fn(nz,ny,1:m,Np))

    sigma = a/sqrt(pi)

    temp2 = (2*pi*sigma**2)**(-1.5)

    do i=1,Np
        dist_sqr = (mesh%x-Yp(i,1))**2 + (mesh%y-Yp(i,2))**2 + (mesh%z-Yp(i,3))**2
	    temp1 = -dist_sqr/(2*sigma**2)
        delta_fn(:,:,:,i) = temp2*exp(temp1)
    end do
end subroutine calc_delta_fn

subroutine updateParticles(Yp,Vp,Vp0,u,v,w)

	implicit none

	double precision, dimension(nz,ny,0:m+1) :: u,v,w
	double precision, dimension(Np,3) :: Yp, Vp, Vp0

    double precision :: dv
    double precision, dimension(Np,3) :: V_loc

	integer :: i

    integer :: id, Nproc, ierr

    !call mpi_comm_rank(MPI_COMM_WORLD, id, ierr)
    !call mpi_comm_size(MPI_COMM_WORLD, Nproc, ierr)

    if (.not. allocated(delta_fn)) then
        !print*, 'Error (forceCoupling): call subroutine calc_delta_fn() before calling forceCoupling()'
        call calc_delta_fn(Yp)
    end if

	Vp0 = Vp

    dv = dx*dy*dz

    do i=1,Np
	!do i=id*(Np/Nproc)+1,min((id+1)*(Np/Nproc),Np)

		!dist_sqr = (x-Yp(i,1))**2 + (y-Yp(i,2))**2 + (z-Yp(i,3))**2

		!temp1 = -dist_sqr/(2*sigma**2)

		V_loc(i,1) = sum(u(:,:,1:m)*delta_fn(:,:,:,i))*dv
		V_loc(i,2) = sum(v(:,:,1:m)*delta_fn(:,:,:,i))*dv
		V_loc(i,3) = sum(w(:,:,1:m)*delta_fn(:,:,:,i))*dv

	end do

    !call mpi_bcast(Vp(id*(Np/Nproc)+1:min((id+1)*(Np/Nproc),Np),:),3*(min((id+1)*(Np/Nproc)-id*(Np/Nproc)+1,Np)),MPI_DOUBLE_PRECISION,id,MPI_COMM_WORLD,ierr)

    call mpi_allreduce(V_loc(:,1),Vp(:,1),Np,MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,ierr)
    call mpi_allreduce(V_loc(:,2),Vp(:,2),Np,MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,ierr)
    call mpi_allreduce(V_loc(:,3),Vp(:,3),Np,MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,ierr)

    !print*, V_loc(1,1), V_loc(1,2), V_loc(1,3)

	Yp = Yp + dt*Vp

end subroutine updateParticles

subroutine forceCoupling(Gx,Gy,Gz,Yp)

	double precision, dimension(nz,ny,1:m) :: Gx,Gy,Gz
	double precision, dimension(Np,3) :: Yp

	double precision, dimension(Np,3) :: F, F_stokes, F_part_coll, F_wall_coll, F_vwf, F_pivkin

	integer :: i

	!integer :: error, Nproc, id

    !print*, 'entered forceCoupling sub'

    call calc_delta_fn(Yp)

	!call mpi_comm_size(MPI_COMM_WORLD, Nproc, error)
    !call mpi_comm_rank(MPI_COMM_WORLD, id, error)

    !if (id==0) then
    !    print*, 'nprocs=', Nproc
    !end if
    !print*, id

	! sigma = a/sqrt(pi)

	! assume particles are neutrally buoyant. therefore no inertia term

	!F =
	!F = 1e-15;

	!temp2 = (2*pi*sigma**2)**(-1.5)

	! Stokes force to ensure terminal velocity of U0
	!F_stokes(:,1) = 6*pi*mu*a*U0
	F_stokes(:,1) = 0
	F_stokes(:,2:3) = 0

	!call particleCollisionForce(F_part_coll,Yp)
	!call wallCollisionForce(F_wall_coll,Yp)
	!call vwfForce(F_vwf,Yp)

	! Exclude other forces for now
	F_part_coll = 0
	F_wall_coll = 0
	F_vwf = 0

	!call pivkinForceField(F_pivkin,Yp)
	F_pivkin = 0

	F = F_stokes + F_part_coll + F_wall_coll + F_vwf + F_pivkin
	!print*, F, -6*pi*mu*a*U0
	!F(:,1) = -6*pi*mu*a*U0; F(:,2:3) = 0
	!F = 0

	Gx = 0; Gy  =0; Gz = 0;

    !print*, id*(Np/Nproc)+1,min((id+1)*(Np/Nproc),Np)

    ! local sum
	!do i=id*(Np/Nproc)+1,min((id+1)*(Np/Nproc),Np)
	do i=1,Np

		!dist_sqr = (x-Yp(i,1))**2 + (y-Yp(i,2))**2 + (z-Yp(i,3))**2

		!temp1 = -dist_sqr/(2*sigma**2)

		Gx = Gx + F(i,1)*delta_fn(:,:,:,i)/rho
		Gy = Gy + F(i,2)*delta_fn(:,:,:,i)/rho
		Gz = Gz + F(i,3)*delta_fn(:,:,:,i)/rho

	end do

    !print *, 'before allreduce'

    !call mpi_allreduce(Gx_loc,Gx,nx*ny*nz,MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,error)
    !call mpi_allreduce(Gy_loc,Gy,nx*ny*nz,MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,error)
    !call mpi_allreduce(Gz_loc,Gz,nx*ny*nz,MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,error)

    !print*, 'after allreduce'

end subroutine forceCoupling

subroutine pivkinForceField(F,Yp)

	double precision, dimension(Np,3) :: Yp
	double precision, dimension(Np,3) :: F

	double precision, dimension(3) :: r, r_wall

	double precision :: r_mag, r_wall_mag

	integer :: i,j

	! parameters
	double precision, parameter :: R_piv = 1.0
	double precision, parameter :: L_piv = 1.5
	double precision, parameter :: B_piv = 3.5
	double precision, parameter :: M_piv = (L_piv+B_piv)/2
	double precision, parameter :: alpha_piv = 4e-12

	do i=1,Np
		F(i,:) = 0

		! Wall
		r_wall_mag = a - sqrt(Yp(i,2)**2+Yp(i,3)**2)
		r_wall(1)=0; r_wall(2)=Yp(i,2);	r_wall(3)=Yp(i,3);
		r_wall = -r_wall_mag*r_wall/sqrt(sum(r_wall**2))	! directed away from wall
		if (r_wall_mag/a <= R_piv) then
			F(i,:) = F(i,:) + 2*alpha_piv*(1-(r_wall_mag/a)/R_piv)*r_wall/r_wall_mag
		end if

		! other particles
		do j=1,Np
			if (i/=j) then
				r = Yp(i,:)-Yp(j,:)	! directed j -> i
				r_mag = sqrt(sum(r**2))
				if (r_mag/a <= R_piv) then
					F(i,:) = F(i,:) + 2*alpha_piv*(1-(r_mag/a)/R_piv)*r/r_mag ! repulsive
				else if ( (r_mag/a >= R_piv) .and. (r_mag/a <= L_piv) ) then
					F(i,:) = F(i,:) + 0
				else if ( (r_mag/a >= L_piv) .and. (r_mag/a <= M_piv) ) then
					F(i,:) = F(i,:) - alpha_piv*((r_mag/a)/L_piv-1)*r/r_mag ! attractive
				else if ( (r_mag/a >= M_piv) .and. (r_mag/a <= B_piv) ) then
					F(i,:) = F(i,:) - alpha_piv*(M_piv/L_piv-1)*((B_piv-(r_mag/a))/(B_piv-M_piv))*r/r_mag ! attractive
				end if
			end if
		end do

	end do

end subroutine pivkinForceField

subroutine particleCollisionForce(F,Yp)

	double precision, dimension(Np,3) :: Yp

	double precision :: R_ref
	double precision :: F_ref
	double precision, dimension(3) :: r			! r vector from j to i
	double precision, dimension(Np,3) :: F		! force vector for each particle
	double precision :: r_mag

	integer :: i, j

	! Parameters
	R_ref = 2.001*a
	F_ref = 1e-20

	do i=1,Np
		F(i,:) = 0

		! other particles
		do j=1,Np
			if (i/=j) then
				r = Yp(i,:)-Yp(j,:)
				r_mag = sqrt(sum(r**2))
				if (r_mag < R_ref) then
					F(i,:) = F(i,:) + F_ref*( (R_ref**2 - r_mag**2)/(R_ref**2 - 4*a**2) )**2 * r / r_mag
				end if
			end if
		end do

	end do

end subroutine particleCollisionForce

subroutine wallCollisionForce(F,Yp)

	double precision, dimension(Np,3) :: F		! force vector for each particle
	double precision, dimension(Np,3) :: Yp

	double precision, dimension(3) :: r					! axis -> Yp
	double precision :: r_mag

	double precision :: R_ref		! close to channel RADIUS
	double precision :: F_ref		! force

	integer :: i

	! Parameters
	R_ref = 0.999*RADIUS
	F_ref = 1e-10

	F = 0

	do i=1,Np
		r(1) = 0; r(2) = Yp(i,2)-Ly/2; r(3) = Yp(i,3)-Lz/2
		r_mag = sqrt(sum(r**2))
		if (r_mag > R_ref) then
			F(i,:) = F_ref*( (r_mag**2 - R_ref**2)/(RADIUS**2 - R_ref**2) )**2 * r / r_mag
		end if
	end do

end subroutine wallCollisionForce

subroutine vwfForce(F,Yp)
	double precision, dimension(Np,3) :: F		! force vector for each particle
	double precision, dimension(Np,3) :: Yp

	double precision :: x0, y0, z0 	! location of injury

	double precision, dimension(3) :: r			! r vector from j to i
	double precision :: r_mag
	double precision :: vwfRange

	double precision :: F_ref

	integer :: i

	x0 = 30e-6; y0=0.0; z0 = Lz/2;
	vwfRange = 5e-6
	F_ref = 1e-10

	F = 0

	do i=1,Np

		r(1) = Yp(i,1) - x0; r(2) = Yp(i,2) - y0; r(3) = Yp(i,3) - z0;
		r_mag = sqrt(sum(r**2))

		if (r_mag<vwfRange) then
			F(i,:) = -F_ref* r
		end if
	end do

end subroutine vwfForce

subroutine fbgForce(F,Yp)

	! depends on local fbg concentration
	! To be added when biochem is implemented

	double precision, dimension(Np,3) :: F		! force vector for each particle
	double precision, dimension(Np,3) :: Yp

	double precision, dimension(3) :: r			! r vector from j to i
	double precision :: r_mag

	integer :: i, j

	do i=1,Np
		F(i,:) = 0

	end do

end subroutine fbgForce

end module fcm


!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 1998 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                         Spherepack                            *
!     *                                                               *
!     *       A Package of Fortran Subroutines and Programs           *
!     *                                                               *
!     *              for Modeling Geophysical Processes               *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *                  John Adams and Paul Swarztrauber             *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
submodule(gradient_routines) invert_gradient_regular_grid

contains

    !     subroutine igradec(nlat, nlon, isym, nt, sf, isf, jsf, br, bi, mdb, ndb, &
    !                        wshsec, ierror)
    !
    !     let br, bi, cr, ci be the vector spherical harmonic coefficients
    !     precomputed by vhaec for a vector field (v, w).  let (v', w') be
    !     the irrotational component of (v, w) (i.e., (v', w') is generated
    !     by assuming cr, ci are zero and synthesizing br, bi with vhsec).
    !     then subroutine igradec computes a scalar field sf such that
    !
    !            gradient(sf) = (v', w').
    !
    !     i.e.,
    !
    !            v'(i, j) = d(sf(i, j))/dtheta          (colatitudinal component of
    !                                                 the gradient)
    !     and
    !
    !            w'(i, j) = 1/sint*d(sf(i, j))/dlambda  (east longitudinal component
    !                                                 of the gradient)
    !
    !     at colatitude
    !
    !            theta(i) = (i-1)*pi/(nlat-1)
    !
    !     and longitude
    !
    !            lambda(j) = (j-1)*2*pi/nlon
    !
    !     where sint = sin(theta(i)).  required associated legendre polynomials
    !     are recomputed rather than stored as they are in subroutine igrades. this
    !     saves storage (compare lshsec and lshses in igrades) but increases
    !     computational requirements.
    !
    !     note:  for an irrotational vector field (v, w), subroutine igradec
    !     computes a scalar field whose gradient is (v, w).  in ay case,
    !     subroutine igradec "inverts" the gradient subroutine gradec.
    !
    !
    !     input parameters
    !
    !     nlat   the number of colatitudes on the full sphere including the
    !            poles. for example, nlat = 37 for a five degree grid.
    !            nlat determines the grid increment in colatitude as
    !            pi/(nlat-1).  if nlat is odd the equator is located at
    !            grid point i=(nlat + 1)/2. if nlat is even the equator is
    !            located half way between points i=nlat/2 and i=nlat/2+1.
    !            nlat must be at least 3. note: on the half sphere, the
    !            number of grid points in the colatitudinal direction is
    !            nlat/2 if nlat is even or (nlat + 1)/2 if nlat is odd.
    !
    !     nlon   the number of distinct londitude points.  nlon determines
    !            the grid increment in longitude as 2*pi/nlon. for example
    !            nlon = 72 for a five degree grid. nlon must be greater than
    !            3.  the efficiency of the computation is improved when nlon
    !            is a product of small prime numbers.
    !
    !
    !     isym   a parameter which determines whether the scalar field sf is
    !            computed on the full or half sphere as follows:
    !
    !      = 0
    !
    !            the symmetries/antsymmetries described in isym=1, 2 below
    !            do not exist in (v, w) about the equator.  in this case sf
    !            is neither symmetric nor antisymmetric about the equator.
    !            sf is computed on the entire sphere.  i.e., in the array
    !            sf(i, j) for i=1, ..., nlat and  j=1, ..., nlon
    !
    !      = 1
    !
    !            w is antisymmetric and v is symmetric about the equator.
    !            in this case sf is antisymmetyric about the equator and
    !            is computed for the northern hemisphere only.  i.e.,
    !            if nlat is odd sf is computed in the array sf(i, j) for
    !            i=1, ..., (nlat + 1)/2 and for j=1, ..., nlon.  if nlat is even
    !            sf is computed in the array sf(i, j) for i=1, ..., nlat/2
    !            and j=1, ..., nlon.
    !
    !      = 2
    !
    !            w is symmetric and v is antisymmetric about the equator.
    !            in this case sf is symmetyric about the equator and
    !            is computed for the northern hemisphere only.  i.e.,
    !            if nlat is odd sf is computed in the array sf(i, j) for
    !            i=1, ..., (nlat + 1)/2 and for j=1, ..., nlon.  if nlat is even
    !            sf is computed in the array sf(i, j) for i=1, ..., nlat/2
    !            and j=1, ..., nlon.
    !
    !
    !     nt     nt is the number of scalar and vector fields.  some
    !            computational efficiency is obtained for multiple fields.
    !            the arrays br, bi, and sf can be three dimensional corresponding
    !            to an indexed multiple vector field (v, w).  in this case,
    !            multiple scalar synthesis will be performed to compute each
    !            scalar field.  the third index for br, bi, and sf is the synthesis
    !            index which assumes the values k = 1, ..., nt.  for a single
    !            synthesis set nt = 1.  the description of the remaining
    !            parameters is simplified by assuming that nt=1 or that br, bi,
    !            and sf are two dimensional arrays.
    !
    !     isf    the first dimension of the array sf as it appears in
    !            the program that calls igradec. if isym = 0 then isf
    !            must be at least nlat.  if isym = 1 or 2 and nlat is
    !            even then isf must be at least nlat/2. if isym = 1 or 2
    !            and nlat is odd then isf must be at least (nlat + 1)/2.
    !
    !     jsf    the second dimension of the array sf as it appears in
    !            the program that calls igradec. jsf must be at least nlon.
    !
    !     br, bi  two or three dimensional arrays (see input parameter nt)
    !            that contain vector spherical harmonic coefficients
    !            of the vector field (v, w) as computed by subroutine vhaec.
    !     ***    br, bi must be computed by vhaec prior to calling igradec.
    !
    !     mdb    the first dimension of the arrays br and bi as it appears in
    !            the program that calls igradec (and vhaec). mdb must be at
    !            least min(nlat, nlon/2) if nlon is even or at least
    !            min(nlat, (nlon + 1)/2) if nlon is odd.
    !
    !     ndb    the second dimension of the arrays br and bi as it appears in
    !            the program that calls igradec (and vhaec). ndb must be at
    !            least nlat.
    !
    !
    !  wshsec    an array which must be initialized by subroutine shseci.
    !            once initialized,
    !            wshsec can be used repeatedly by igradec as long as nlon
    !            and nlat remain unchanged.  wshsec must not be altered
    !            between calls of igradec.
    !
    !
    !  lshsec    the dimension of the array wshsec as it appears in the
    !            program that calls igradec. define
    !
    !               l1 = min(nlat, (nlon+2)/2) if nlon is even or
    !               l1 = min(nlat, (nlon + 1)/2) if nlon is odd
    !
    !            and
    !
    !               l2 = nlat/2        if nlat is even or
    !               l2 = (nlat + 1)/2    if nlat is odd.
    !
    !
    !            then lshsec must be greater than or equal to
    !
    !               2*nlat*l2+3*((l1-2)*(2*nlat-l1-1))/2+nlon+15
    !
    !     output parameters
    !
    !
    !     sf    a two or three dimensional array (see input parameter nt) that
    !           contain a scalar field whose gradient is the irrotational
    !           component of the vector field (v, w).  the vector spherical
    !           harmonic coefficients br, bi were precomputed by subroutine
    !           vhaec.  sf(i, j) is given at the gaussian colatitude theta(i)
    !           and longitude lambda(j) = (j-1)*2*pi/nlon.  the index ranges
    !           are defined at input parameter isym.
    !
    !
    !  ierror   = 0  no errors
    !           = 1  error in the specification of nlat
    !           = 2  error in the specification of nlon
    !           = 3  error in the specification of isym
    !           = 4  error in the specification of nt
    !           = 5  error in the specification of isf
    !           = 6  error in the specification of jsf
    !           = 7  error in the specification of mdb
    !           = 8  error in the specification of ndb
    !           = 9  error in the specification of lshsec
    !
    module subroutine igradec(nlat, nlon, isym, nt, sf, isf, jsf, br, bi, mdb, ndb, &
        wshsec, ierror)

        ! Dummy arguments
        integer(ip), intent(in)  :: nlat
        integer(ip), intent(in)  :: nlon
        integer(ip), intent(in)  :: isym
        integer(ip), intent(in)  :: nt
        real(wp),    intent(out) :: sf(isf, jsf, nt)
        integer(ip), intent(in)  :: isf
        integer(ip), intent(in)  :: jsf
        real(wp),    intent(in)  :: br(mdb, ndb, nt)
        real(wp),    intent(in)  :: bi(mdb, ndb, nt)
        integer(ip), intent(in)  :: mdb
        integer(ip), intent(in)  :: ndb
        real(wp),    intent(in)  :: wshsec(:)
        integer(ip), intent(out) :: ierror

        ! Local variables
        integer(ip) :: imid, n1, n2, lpimn
        integer(ip) :: required_wavetable_size
        integer(ip) :: mmax

        ! Check calling arguments
        ierror = 1
        if (nlat < 3) return
        ierror = 2
        if (nlon < 4) return
        ierror = 3
        if (isym < 0 .or. isym > 2) return
        ierror = 4
        if (nt < 0) return
        ierror = 5
        imid = (nlat + 1)/2
        if ((isym == 0 .and. isf<nlat) .or. &
            (isym /= 0 .and. isf<imid)) return
        ierror = 6
        if (jsf < nlon) return
        ierror = 7
        mmax = min(nlat, (nlon+2)/2)
        if (mdb < min(nlat, (nlon + 1)/2)) return
        ierror = 8
        if (ndb < nlat) return
        ierror = 9
        imid = (nlat + 1)/2
        lpimn = (imid*mmax*(2*nlat-mmax+1))/2
        !
        !     verify saved workspace length
        !
        n1 = min(nlat, (nlon+2)/2)
        n2 = (nlat + 1)/2
        required_wavetable_size = 2*nlat*n2+3*((n1-2)*(2*nlat-n1-1))/2+nlon+15
        if (size(wshsec) < required_wavetable_size) return
        ierror = 0

        call invert_gradient_lower_utility_routine(nlat, nlon, isym, nt, sf, &
            br, bi, wshsec, shsec, ierror)

    end subroutine igradec

end submodule invert_gradient_regular_grid