c
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c  .                                                             .
c  .                  copyright (c) 1998 by UCAR                 .
c  .                                                             .
c  .       University Corporation for Atmospheric Research       .
c  .                                                             .
c  .                      all rights reserved                    .
c  .                                                             .
c  .                                                             .
c  .                         SPHEREPACK                          .
c  .                                                             .
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
c
c
c ... file shigs.f
c
c     this file contains code and documentation for subroutine shigs
c
c ... files which must be loaded with shigs.f
c
c     sphcom.f, hrfft.f, gaqd.f
c
c     3/6/98
c
c *** shigs is functionally the same as shagsi or shsgsi.  It
c     it included in spherepack3.0 because legacy codes, using
c     the older version of spherepack, call shigs to initialize
c     the saved work space wshigs for either shags or shsgs
c     Its arguments are identical to those of shagsi or shsgsi.
c
c ****************************************************************
c
c     subroutine shigs(nlat,nlon,wshigs,lshigs,work,lwork,dwork,ldwork,
c    +                 ierror)
c
c     subroutine shigs initializes the array wshigs which can then
c     be used repeatedly by subroutines shags,shsgs. it precomputes
c     and stores in wshigs quantities such as gaussian weights,
c     legendre polynomial coefficients, and fft trigonometric tables.
c
c     input parameters
c
c     nlat   the number of points in the gaussian colatitude grid on the
c            full sphere. these lie in the interval (0,pi) and are compu
c            in radians in theta(1),...,theta(nlat) by subroutine gaqd.
c            if nlat is odd the equator will be included as the grid poi
c            theta((nlat+1)/2).  if nlat is even the equator will be
c            excluded as a grid point and will lie half way between
c            theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3.
c            note: on the half sphere, the number of grid points in the
c            colatitudinal direction is nlat/2 if nlat is even or
c            (nlat+1)/2 if nlat is odd.
c
c     nlon   the number of distinct londitude points.  nlon determines
c            the grid increment in longitude as 2*pi/nlon. for example
c            nlon = 72 for a five degree grid. nlon must be greater
c            than or equal to 4. the efficiency of the computation is
c            improved when nlon is a product of small prime numbers.
c
c     wshigs an array which must be initialized by subroutine shigs .
c            once initialized, wshigs can be used repeatedly by shigs
c            as long as nlat and nlon remain unchanged.  wshigs must
c            not be altered between calls of shigs.
c
c     lshigs the dimension of the array wshigs as it appears in the
c            program that calls shigs. define
c
c               l1 = min0(nlat,(nlon+2)/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            and
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c            then lshigs must be at least
c
c            nlat*(3*(l1+l2)-2)+(l1-1)*(l2*(2*nlat-l1)-3*l1)/2+nlon+15
c
c     work   a real work space which need not be saved
c
c     lwork  the dimension of the array work as it appears in the
c            program that calls shigs. lwork must be at least
c            4*nlat*(nlat+2)+2 in the routine calling shigs
c
C*PL*ERROR* Comment line too long
c     dwork   a double precision work array that does not have to be saved.
c
c     ldwork  the length of dwork in the calling routine.  ldwork must
c             be at least nlat*(nlat+4)
c
c     output parameter
c
c     wshags an array which must be initialized before calling shags or
c            once initialized, wshags can be used repeatedly by shags or
c            as long as nlat and nlon remain unchanged.  wshags must not
c            altered between calls of shasc.
c
c     ierror = 0  no errors
c            = 1  error in the specification of nlat
c            = 2  error in the specification of nlon
c            = 3  error in the specification of lshags
c            = 4  error in the specification of lwork
c            = 5  error in the specification of ldwork
c            = 6  failure in gaqd to compute gaussian points
c                 (due to failure in eigenvalue routine)
c
c
c ****************************************************************
c
      SUBROUTINE DSHIGS(NLAT,NLON,WSHIGS,LSHIGS,WORK,LWORK,DWORK,
     +                  LDWORK,IERROR)
      DOUBLE PRECISION WSHIGS
      DOUBLE PRECISION WORK
c
c     this subroutine must be called before calling shags or shsgs with
c     fixed nlat,nlon. it precomputes the gaussian weights, points
c     and all necessary legendre polys and stores them in wshigs.
c     these quantities must be preserved when calling shsgs or shags
c     repeatedly with fixed nlat,nlon.
c
      DIMENSION WSHIGS(LSHIGS),WORK(LWORK)
C*PT*WARNING* Already double-precision
      DOUBLE PRECISION DWORK(LDWORK)

      IERROR = 1
      IF (NLAT.LT.3) RETURN
      IERROR = 2
      IF (NLON.LT.4) RETURN
c     set triangular truncation limit for spherical harmonic basis
      L = MIN0((NLON+2)/2,NLAT)
c     set equator or nearest point (if excluded) pointer
      LATE = (NLAT+1)/2
      L1 = L
      L2 = LATE
c     check permanent work space length
      IERROR = 3
      LP = NLAT* (3* (L1+L2)-2) + (L1-1)* (L2* (2*NLAT-L1)-3*L1)/2 +
     +     NLON + 15
      IF (LSHIGS.LT.LP) RETURN
      IERROR = 4
c     check temporary work space
      IF (LWORK.LT.4*NLAT* (NLAT+2)+2) RETURN
c     check temp double precision space
      IERROR = 5
      IF (LDWORK.LT.NLAT* (NLAT+4)) RETURN
      IERROR = 0
C*PL*ERROR* Comment line too long
c     set preliminary quantites needed to compute and store legendre polys
      CALL DSHIGSP(NLAT,NLON,WSHIGS,LSHIGS,DWORK,LDWORK,IERROR)
      IF (IERROR.NE.0) RETURN
c     set legendre poly pointer in wshigs
      IPMNF = NLAT + 2*NLAT*LATE + 3* (L* (L-1)/2+ (NLAT-L)* (L-1)) +
     +        NLON + 16
      CALL DSHIGSS1(NLAT,L,LATE,WSHIGS,WORK,WSHIGS(IPMNF))
      RETURN
      END

      SUBROUTINE DSHIGSS1(NLAT,L,LATE,W,PMN,PMNF)
      DOUBLE PRECISION W
      DOUBLE PRECISION PMN
      DOUBLE PRECISION PMNF
      DIMENSION W(1),PMN(NLAT,LATE,3),PMNF(LATE,1)
c     compute and store legendre polys for i=1,...,late,m=0,...,l-1
c     and n=m,...,l-1
      DO I = 1,NLAT
          DO J = 1,LATE
              DO K = 1,3
                  PMN(I,J,K) = 0.0D0
              END DO
          END DO
      END DO
      DO 100 MP1 = 1,L
          M = MP1 - 1
          MML1 = M* (2*NLAT-M-1)/2
c     compute pmn for n=m,...,nlat-1 and i=1,...,(l+1)/2
          MODE = 0
          CALL DLEGIN(MODE,L,NLAT,M,W,PMN,KM)
c     store above in pmnf
          DO 101 NP1 = MP1,NLAT
              MN = MML1 + NP1
              DO 102 I = 1,LATE
                  PMNF(I,MN) = PMN(NP1,I,KM)
  102         CONTINUE
  101     CONTINUE
  100 CONTINUE
      RETURN
      END
      SUBROUTINE DSHIGSP(NLAT,NLON,WSHIGS,LSHIGS,DWORK,LDWORK,IERROR)
      DOUBLE PRECISION WSHIGS
      DIMENSION WSHIGS(LSHIGS)
C*PT*WARNING* Already double-precision
      DOUBLE PRECISION DWORK(LDWORK)

      IERROR = 1
      IF (NLAT.LT.3) RETURN
      IERROR = 2
      IF (NLON.LT.4) RETURN
c     set triangular truncation limit for spherical harmonic basis
      L = MIN0((NLON+2)/2,NLAT)
c     set equator or nearest point (if excluded) pointer
      LATE = (NLAT+MOD(NLAT,2))/2
      L1 = L
      L2 = LATE
      IERROR = 3
c     check permanent work space length
      IF (LSHIGS.LT.NLAT* (2*L2+3*L1-2)+3*L1* (1-L1)/2+NLON+15) RETURN
      IERROR = 4
c     if (lwork.lt.4*nlat*(nlat+2)+2) return
      IF (LDWORK.LT.NLAT* (NLAT+4)) RETURN
      IERROR = 0
c     set pointers
      I1 = 1
      I2 = I1 + NLAT
      I3 = I2 + NLAT*LATE
      I4 = I3 + NLAT*LATE
      I5 = I4 + L* (L-1)/2 + (NLAT-L)* (L-1)
      I6 = I5 + L* (L-1)/2 + (NLAT-L)* (L-1)
      I7 = I6 + L* (L-1)/2 + (NLAT-L)* (L-1)
c     set indices in temp work for double precision gaussian wts and pts
      IDTH = 1
c     idwts = idth+2*nlat
c     iw = idwts+2*nlat
      IDWTS = IDTH + NLAT
      IW = IDWTS + NLAT
      CALL DSHIGSP1(NLAT,NLON,L,LATE,WSHIGS(I1),WSHIGS(I2),WSHIGS(I3),
     +              WSHIGS(I4),WSHIGS(I5),WSHIGS(I6),WSHIGS(I7),
     +              DWORK(IDTH),DWORK(IDWTS),DWORK(IW),IERROR)
      IF (IERROR.NE.0) IERROR = 5
      RETURN
      END

      SUBROUTINE DSHIGSP1(NLAT,NLON,L,LATE,WTS,P0N,P1N,ABEL,BBEL,CBEL,
     +                    WFFT,DTHETA,DWTS,WORK,IER)
      DOUBLE PRECISION WTS
      DOUBLE PRECISION P0N
      DOUBLE PRECISION P1N
      DOUBLE PRECISION ABEL
      DOUBLE PRECISION BBEL
      DOUBLE PRECISION CBEL
      DOUBLE PRECISION WFFT
      DOUBLE PRECISION FN
      DOUBLE PRECISION FM
      DIMENSION WTS(NLAT),P0N(NLAT,LATE),P1N(NLAT,LATE),ABEL(1),BBEL(1),
     +          CBEL(1),WFFT(1),DTHETA(NLAT),DWTS(NLAT)
C*PT*WARNING* Already double-precision
      DOUBLE PRECISION PB,DTHETA,DWTS,WORK(*)

      INDX(M,N) = (N-1)* (N-2)/2 + M - 1
      IMNDX(M,N) = L* (L-1)/2 + (N-L-1)* (L-1) + M - 1
      CALL DHRFFTI(NLON,WFFT)
c     compute double precision gaussian points and weights
c     lw = 4*nlat*(nlat+2)
      LW = NLAT* (NLAT+2)
      CALL DGAQD(NLAT,DTHETA,DWTS,WORK,LW,IER)
      IF (IER.NE.0) RETURN
c     store gaussian weights single precision to save computation
c     in inner loops in analysis
      DO 100 I = 1,NLAT
          WTS(I) = DWTS(I)
  100 CONTINUE
c     initialize p0n,p1n using double precision dnlfk,dnlft
      DO 101 NP1 = 1,NLAT
          DO 101 I = 1,LATE
              P0N(NP1,I) = 0.0D0
              P1N(NP1,I) = 0.0D0
  101 CONTINUE
c     compute m=n=0 legendre polynomials for all theta(i)
      NP1 = 1
      N = 0
      M = 0
      CALL DDNLFK(M,N,WORK)
      DO 103 I = 1,LATE
          CALL DDNLFT(M,N,DTHETA(I),WORK,PB)
          P0N(1,I) = PB
  103 CONTINUE
c     compute p0n,p1n for all theta(i) when n.gt.0
      DO 104 NP1 = 2,NLAT
          N = NP1 - 1
          M = 0
          CALL DDNLFK(M,N,WORK)
          DO 105 I = 1,LATE
              CALL DDNLFT(M,N,DTHETA(I),WORK,PB)
              P0N(NP1,I) = PB
  105     CONTINUE
c     compute m=1 legendre polynomials for all n and theta(i)
          M = 1
          CALL DDNLFK(M,N,WORK)
          DO 106 I = 1,LATE
              CALL DDNLFT(M,N,DTHETA(I),WORK,PB)
              P1N(NP1,I) = PB
  106     CONTINUE
  104 CONTINUE
c
c     compute and store swarztrauber recursion coefficients
c     for 2.le.m.le.n and 2.le.n.le.nlat in abel,bbel,cbel
      DO 107 N = 2,NLAT
          FN = DBLE(N)
          MLIM = MIN0(N,L)
          DO 107 M = 2,MLIM
              FM = DBLE(M)
              IMN = INDX(M,N)
              IF (N.GE.L) IMN = IMNDX(M,N)
              ABEL(IMN) = SQRT(((2*FN+1)* (FM+FN-2)* (FM+FN-3))/
     +                    (((2*FN-3)* (FM+FN-1)* (FM+FN))))
              BBEL(IMN) = SQRT(((2*FN+1)* (FN-FM-1)* (FN-FM))/
     +                    (((2*FN-3)* (FM+FN-1)* (FM+FN))))
              CBEL(IMN) = SQRT(((FN-FM+1)* (FN-FM+2))/
     +                    (((FN+FM-1)* (FN+FM))))
  107 CONTINUE
      RETURN
      END


C++********************************************************************
C Program HANKEL
C To smooth a radial profile using an arbitrary PSF. Uses
C Hankel transforms of the PSF and the surface brightness profile.
C From Timothy Bruce (Stromlo)
C Version of 22-09-86
C--********************************************************************
	PROGRAM HANKEL
	implicit real*8 (a-h,o-z)

	parameter (dim=200)

	dimension grd(dim), rpsf(dim), rsb(dim), psf(dim),
     $           hpsf(10*dim), sb(dim), hsba(10*dim),hsb(10*dim),
     $           sba(dim), xkk(10*dim)

	real*4 sbalog(dim), sblog(dim), rlog(dim), hpsfpl(10*dim),
     $         hsbapl(10*dim), hsbpl(10*dim), xkpl(10*dim)

	character ans*1
        open(unit=30,name='xsubrapp.dat',status='new')
	pi=3.14159265358979323846
	twopi = 2.0 * pi
c--------------------------------------------------------------------------

	print *, 'First evaluate the Hankel transforms of the PSF and the'
	print *, 'Surface Brightness'

	print *, 'Read in PSF from table'

        open(unit=10,name='normipc.dat',status='old')
        do 1 i=1,200
        read(10,*,end=111)rpsf(i),psf(i)
        write(6,*)i,rpsf(i),psf(i)
        npsf=i
1       continue
c    	call filin (rpsf, psf, npsf )

111     print *, 'Read in radial surface brightness profile from table'

        open(unit=11,name='tnlolo.dat',status='old')
        do 2 j=1,200
        read(11,*,end=112)rsb(j),sb(j)
        write(6,*)j,rsb(j),sb(j)
        nsb=j
2       continue
c	call filin ( rsb, sb, nsb )

112	print *, 'Is surface brightness data in log-log form?  (y/n)'
	accept 10, ans
10	format (a1)
	if (ans.eq.'n'.or.ans.eq.'N') goto 50
	print *, 'Converting surface brightness to linear form.'
	do 40 i = 1,nsb
	rsb(i) = 10.0**rsb(i)
	sb(i)  = 10.0**sb(i)
40	continue
50	continue

	print *, 'Largest increment in radius of surface brightness profile.'
	accept *, delr
	rmax = rsb(nsb)

c	Increment and Maximum value of radial wave number.

	delk = 1.0 /( 2.0 * rmax )
	xkmax = 2.0 / delr
	kmax = xkmax/delk + 4

c	Evaluate Hankel transforms of PSF and Surface Brightness.

	ifail = 0

	do 100  k = 1, kmax

	xk = (k-1) * delk
	xkpl(k) = xk
		do 90 i = 1, nsb

		r = rpsf(i)
		arg = xk * r

C Calling NAG routine S17AEF
		grd(i) = r * psf(i) * s17aef (arg, ifail)

90		continue

C Calling NAG routine D01GAF:
		call d01gaf (rpsf, grd, npsf, res, er, ifail)
		hpsf(k) = res
		hpsfpl(k) = res
100 	continue

	do 200 k = 1, kmax
	xk = (k-1)*delk
		do 190 i=1,nsb
		r = rsb(i)
		arg = xk * r
C Calling NAG routine S17AEF
		grd(i) = r * sb(i) * s17aef (arg, ifail)
190 	continue

C Calling NAG routine D01GAF:
        print *,'calling do1gaf(surf br)'
	call d01gaf (rsb, grd, nsb, res, er, ifail)
	hsb(k) = res
	hsbpl(k) = res
200	continue

	do 300 k = 1, kmax
	hsba(k) = twopi * hsb(k) * hpsf(k)
	hpsfpl(k) = hpsf(k)
300	continue

	call curve (kmax, xkpl, hpsfpl )
	call curve (kmax, xkpl, hsbpl )
	call gratek ( 'k', 'Hankel Transform', 'PSF and Surface Brightness',
     $	                   's,tickin')

	print *, 'Inverse Hankel Transform to determine Apparent Surface'
	print *, 'Brightness.'

	do 400 i = 1, nsb
		r = rsb(i)
		do 390 k = 1, kmax
			xk = (k-1) * delk
			xkk(k) = xk
			arg = xk * r
			grd(k) = xk * hsba(k) * s17aef (arg, ifail)
390			continue

C Calling NAG routine D01GAF:
                print *,'do1gaf(xkk,grd,kmax)'
		call d01gaf ( xkk, grd, kmax, res, er, ifail)
		sba(i) = res
		sbalog(i) = dlog10 ( sba(i) )
		sblog(i)  = dlog10 ( sb(i) )
       		if (rsb(i).gt.0.000001) then
 		rlog(i)   = dlog10 ( rsb(i) )
                 write(6,*)rlog(i),sbalog(i),sblog(i)
                 write(30,*)rlog(i),sbalog(i),sblog(i)
		else
		rlog(i) = -4.0
		end if

400	continue

	call curve ( nsb, rlog, sblog )
	call curve ( nsb, rlog, sbalog )

	call gratek ( 'log r', 'log SB',
     $                'Real and Apparent Surface Brightness',
     $			's,tickin' )

	end


c=======================================================================
c
c     subroutine MULTIVOL
c
c     Risk Budgeting allocation strategy
c
c     Max[ w'*rho ]
c      s.t.
c     sqrt[w'*Q(i)*w] <= sigma(i)  (volatility constraint)
c     C*w <= b                     (linear constraints)
c     Cinf <= w <= Csup            (lower/upper bounds)
c
c        w   : portfolio weights
c        Q   : covariance matrix
c        rho : assets performance
c
c-----------------------------------------------------------------------
      SUBROUTINE multivol ( n, cov, rho, neq, nin, ccst, bcst,
     &                      cinf, csup, nbc, class, sigma,
     &                      iwork, dwork, wopt, lambda, info )
c-----------------------------------------------------------------------
c
c     INPUT
c       n      : portfolio size                                  integer
c       cov    : covariance matrix (n*n)                          double
c       rho    : expected returns vector (n)                      double
c       neq    : number equality constraints                     integer
c       nin    : number inequality constraints                   integer
c       ccst   : matrix of constraints (nasset*(neq+nin))         double
c       bcst   : vector initial of constraints (neq+nin)          double
c       cinf   : lower bound (n)                                  double
c       csup   : upper bound (n)                                  double
c       nbc    : number of risk budgeting constraints (>=1)      integer
c       class  : block definition (n)                            integer
c       sigma  : volatilities budgets constraints (nbc)           double
c
c     WORKSPACE
c       iwork  : 3*nbc + 4*n + neq + 2*nin + 6                   integer
c       dwork  : nbc*(nbc+21)/2 + n*(5*n+neq+nin+12)+2*neq+4*nin  double
c
c     OUTPUT
c       wopt   : optimal portfolio (n)                            double
c       lambda : optimal lambda (nbc)
c       info   : diagnostic argument                             integer
c
c     CALL
c       SIMMVOL, TESTSDP, OPVOL, OVTMCV, IVX, YV, BFGSMVOL
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
      EXTERNAL simvol, simext
c
c     arguments i/o
      INTEGER n, info, neq, nin, nbc
      INTEGER class(*)
      DOUBLE PRECISION cov(*), rho(*), cinf(*), csup(*), ccst(n,*),
     &                 bcst(*), wopt(*), sigma(*), lambda(*)
c
c     workspaces
      INTEGER iwork(*)
      DOUBLE PRECISION dwork(*)
c
c     local variables
      INTEGER i, j, l, k, npk, totitr, totsim, ntot, infoBFGS
      INTEGER piwbf, pisim, pinfo, pin, pineq, pinin, piclass,
     &        pydual, pbinf, pbsup, pgrad, pwbf, psim,
     &        pdcov, pdrho, pdcinf, pdcsup, pdsigma, pdc, pdb, pdwo,
     &        pdcov1
      DOUBLE PRECISION funct, epsbfg, t, var, volmin, stotal, dualopt
      DOUBLE PRECISION INFINI, MINFINI, ZERO, EPS, ONE, COEF
      PARAMETER (INFINI=1.E15,ZERO=0.E0,EPS=1.E-16,ONE=1E0,COEF=-0.5E0)
      PARAMETER (MINFINI = -1.E10)
c
c     external subroutines
      EXTERNAL testsdp, opvol, OVTMCV, IVX, YV, bfgsmvol
c
c     intrinsic functions
c
c-----------------------------------------------------------------------
c
c
c     initializations
      info = 0
      ntot = neq + nin
c
c     pointers for integer work space : iwork
c     ---------------------------------------
      piwbf = 1
c     piwbf : pointer for BFGSBOX who needs (2*nbc + 1)
      pisim  = piwbf + (2*nbc + 1)
c     pisim : pointer for simulator SIMMVOL (5*n + neq + 2*nin + 5)
      pinfo = pisim
c     pinfo : pointer for info (errors of simul), so 1 more
      pin   = pinfo + ( 1 )
c     pin   : pointer for value of n, so 1 more
      pineq = pin + ( 1 )
c     pineq : pointer for value of neq, so 1 more
      pinin = pineq + ( 1 )
c     pinin : pointer for value of nin, so 1 more
      piclass = pinin + ( 1 )
c     piclass: pointer for value of class, so n more
c
c     Total size of dwork array = (2*nbc + 1) + (5*n + neq + 2*nin + 5)
c                               = 2*nbc + 5*n + neq + 2*nin + 6
c
c     pointers for double precision work space  : dwork
c     -------------------------------------------------
      pydual = 1
c     pydual: pointer for initial value of ydual (nbc)
      pbinf = pydual + ( nbc )
c     pbinf : pointer for inferior bounds binf (nbc)
      pbsup = pbinf + ( nbc )
c     pbsup : pointer for superior bounds bsup (nbc)
      pgrad = pbsup + ( nbc )
c     pgrad : pointer for gradient at solution (nbc)
c
      pwbf = pgrad + ( nbc )
c     pwbf  : pointer for BFGSMVOL ( nbc*(nbc+11)/2 )
c
      psim = pwbf + ( nbc*(nbc+11)/2 )
c     psim  : pointer for the simulator SIMMVOL
c             ( n*(4*n+neq+nin+12)+nvar+2*neq+4*nin )
      pdcov   = psim
c     pdcov : pointer for cov. matrix (n*n)
      pdrho   = pdcov + ( n*n )
c     pdrho : pointer for expected returns (n)
      pdcinf  = pdrho + ( n )
c     pdcinf : pointer for lower bounds (n)
      pdcsup  = pdcinf + ( n )
c     pdcsup : pointer for upper bounds (n)
      pdsigma = pdcsup + ( n )
c     pdsigma : pointer for risk budget constraint (nbc)
      pdc     = pdsigma + ( nbc )
c     pdc : pointer for matrix constraint (n*(neq+nin))
      pdb     = pdc + ( n*(neq + nin) )
c     pdb : pointer for vector constraint (neq+nin)
      pdwo    = psim + (n + neq + nin + 1)
c     pdwo :
      pdcov1  = pdb + ( neq + nin )
c     pdcov1  : temporary cov. matrix ( n*n )
c
c     Total size of dwork array = 4*nbc + ( nbc*(nbc+11)/2 )
c                               + n*(4*n+neq+nin+12)+nbc+2*neq+4*nin
c                               + n*n
c           = nbc*(nbc+21)/2 + n*(5*n+neq+nin+12)+2*neq+4*nin
c
c-----------------------------------------------------------------------
c
c      TODO - test if classes are not all null
c
c      open(unit=1,file='MULTIVOL.txt',status='unknown')
c      write(1,*) "--- BEGIN MULTIVOL ---"
c
c-----------------------------------------------------
c     satisfiability conditions (well-defined problem)
c-----------------------------------------------------
c
c     test if the covariance matrix is SDP
      CALL testsdp (n, cov, iwork(pisim), dwork(psim), info)
      IF (info .NE. 0) THEN
         info = -108
         RETURN
      ENDIF
c
c--------------------------------------------------------------
c     construction of work vectors (communication with simmvol)
c--------------------------------------------------------------
c
c     initialization
      CALL IVX ( nbc, dwork(pydual), ONE )   ! dual
      CALL IVX ( nbc, dwork(pbinf), ZERO )   ! lower bounds
      CALL IVX ( nbc, dwork(pbsup), INFINI ) ! upper bounds
c
c     construct of iwork (communication with simmvol)
      iwork(pinfo) = 0       ! diagnostic argument
      iwork(pin)   = n       ! number of asset(s)
      iwork(pineq) = neq     ! number of eq. constraint(s)
      iwork(pinin) = nin     ! number of ineq. constraint(s)
      CALL YVI ( n, class, iwork(piclass) ) ! cov. matrix partition
c
c     construct dwork (communication with simmvol)
      CALL YV ( n*n, cov, dwork(pdcov) )     ! cov. matrix
      CALL YV ( n, rho, dwork(pdrho) )       ! rho
      CALL YV ( n, cinf, dwork(pdcinf) )     ! lower bounds
      CALL YV ( n, csup, dwork(pdcsup) )     ! upper bounds
      CALL YV ( nbc, sigma, dwork(pdsigma) ) ! risk budget(s)
      CALL YM ( n, ntot, ccst, dwork(pdc) )  ! constraint matrix
      CALL YV ( ntot, bcst, dwork(pdb) )     ! constraint vector
c
c-------------------------------------------------------------------
c     Non Linear optimization (BFGS)
c-------------------------------------------------------------------
      epsbfg = 1.E-10
      CALL bfgsmvol ( SIMMVOL, gesterr, nbc, dwork(pydual), epsbfg,
     &                dwork(pbinf), dwork(pbsup),
     &                iwork(piwbf), dwork(pwbf),
     &                funct, dwork(pgrad), totitr, totsim, info)
      CALL YV ( nbc, dwork(pydual), lambda ) ! ydual -> lambda
      infoBFGS = info
c      write(1,*) "-------- BFGS info=", info , "-------"
c      write(1,*) "totitr=", totitr ,", totsim= ", totsim
c      write(1,*) "F(wopt)=", funct
c      write(1,*) "Gradient:"
c      write(1,1) (dwork(pgrad + i - 1), i=1,nbc)
c      write(1,*) "xopt:"
c      write(1,1) (dwork(pydual + i - 1), i=1,nbc)
c      write(1,*) "-----------------------"
c
c     gestion of SIMMVOL errors
c      info = iwork(pinfo)
c      IF (info .LT. 0) RETURN
c
c--------------------------------------------
c     Optimize with optimal lambda
c--------------------------------------------
c
      CALL IMX ( n, n, dwork(pdcov), ZERO ) ! initialize pdcov
c
c     construct cov. matrix
      DO i = 1,nbc
c
         CALL IVX ( n, iwork(piwbf), ZERO ) ! initialize piwbf
c
c        dimension of block i
         npk = 0
         DO j = 1,n
            IF (class(j) .EQ. i) THEN
               npk = npk + 1
               iwork(piwbf + npk - 1) = j
            ENDIF
         ENDDO
         IF (npk .GT. 1) THEN
c
c           initialize temporary cov. matrix
            CALL IMX ( npk, npk, dwork(pdcov1), ZERO )
c
c           extract block i
            CALL YMCPI ( n, cov, npk, iwork(piwbf), dwork(pdcov1), info)

c            write(1,*) "quadratic part, block:",i
c            do l = 1,npk
c              write(1,1)(dwork(pdcov1 + (l-1)*npk + k - 1),k=1,npk)
c            enddo

c
c           product lambda(i)*cov(i)
            CALL PMX (npk, npk, dwork(pdcov1), lambda(i), dwork(pdcov1))

c            write(1,*) "quadratic part * lambda"
c            do l = 1,npk
c              write(1,1)(dwork(pdcov1 + (l-1)*npk + k - 1),k=1,npk)
c            enddo
c
c           sub-block -> cov. matrix
            CALL YMCPIR (npk, dwork(pdcov1), n, iwork(piwbf),
     &                   dwork(pdcov), info)

c            write(1,*) "Index:"
c            write(1,*) (iwork(piwbf + k - 1), k=1,n)
c            write(1,*) "quadratic part:"
c            do l = 1,n
c              write(1,1)(dwork(pdcov + (l-1)*n + k - 1),k=1,n)
c            enddo

         ENDIF
      ENDDO
c
c     linear part: l(i) = -0.5*rho(i)
      CALL PVX ( n, rho, COEF, dwork(pdrho) )
c
c     quadratic solver
      CALL qp ( n, dwork(pdcov), dwork(pdrho), neq, nin,
     &          ccst, bcst, cinf, csup,
     &          iwork(piclass), dwork(pdb),
     &          dwork(pdcinf), wopt, info )
      IF (info .LT. 0) RETURN

c      write(1,*) "QP info=", info
c
c     global risk: SQRT(w'*COV*w)
c      CALL OVTMCV ( n, cov, wopt, var)
c      var = SQRT(var)
c
c      write(1,*) "wopt="
c      write(1,1) (wopt(i), i=1,n)
c      write(1,*) "cov. matrix"
c      do i = 1,n
c         write(1,1)(cov((i-1)*n + j),j=1,n)
c      enddo
c      write(1,*) "cinf="
c      write(1,1) (cinf(i), i=1,n)
c      write(1,*) "csup="
c      write(1,1) (csup(i), i=1,n)
c      write(1,*) "neq=", neq
c      write(1,*) "nin=", nin
c      write(1,*) "constraint matrix:"
c      do i = 1,(neq+nin)
c        write(1,1) (ccst(j,i), j=1,n)
c      enddo
c      write(1,*) "constraint vector:"
c      write(1,1) (bcst(i), i=1,(neq+nin))
c      write(1,*) "linear part:"
c      write(1,1) (dwork(pdrho + i - 1), i=1,n)
c      write(1,*) "quadratic part:"
c      do i = 1,n
c         write(1,1)(dwork(pdcov + (i-1)*n + j - 1),j=1,n)
c      enddo
c    1 format(50f10.6)
c      write(1,*) "--- END MULTIVOL ---"
c      close(unit=1)

c
c-------------------------------------------------------------
c     test if the ith-volatility budget constraint is too high/small
c     (budget constraint not attainable) -> info = 111/110
c-------------------------------------------------------------
c
      DO i = 1,nbc
        IF (ABS(lambda(i)) .LT. EPS) THEN
            info = 111
        ENDIF
        IF (ABS(lambda(i)) .GT. 1.E+14) THEN
            info = 110
        ENDIF
      ENDDO
c
c     BFGS diagnostic
      IF ((infoBFGS .NE. 0) .AND. (info .EQ. 0)) THEN
        info = infoBFGS
      ENDIF
c
c--------------------------------------------
c     Lagrange multiplier (budget constraint)
c--------------------------------------------
c
c     TODO
c
      RETURN
      END


! *********************************************************************
! *                                                                   *
! *                           function dcvaa2                         *
! *                                                                   *
! *********************************************************************
! Double Precision Version 1.5
! Written by Gordon A. Fenton, DalTech, July 17, 1992
! Latest Update: Jul 2, 2003
!
! PURPOSE  returns the covariance between two 2-D local averages of equal
!          area. Used by LAS2G.
!
! This function evaluates the covariance between two local averages in
! 2-dimensional space. The local averages are assumed to be of equal
! size, Dx x Dy, and separated in space by the lags Tx=C1*Dx and Ty=C2*Dy.
!
! The covariance is obtained by a 16-pt Gaussian quadrature of a
! 4-D integral collapsed (by assuming the covariance function to be
! quadrant symmetric) to a 2-D integral.
! NOTE: if the covariance function is not quadrant symmetric, this
!       routine will return erroneous results. Quadrant symmetry means
!       that cov(X,Y) = cov(-X,Y) = cov(X,-Y) = cov(-X,-Y), where
!       cov(.,.) is the function returning the covariance between
!       points separated by lag (X,Y), as discussed next.
!
! The covariance function is referenced herein using a call of the
! form
!
!         V = cov( X, Y )
!
! where X and Y are the lag distances between the points in the field.
!
! Arguments to this function are as follows
!
!   cov       external covariance function provided by the user.
!
!   Dx        x-dimension of each local average. (input)
!
!   Dy        y-dimension of each local average. (input)
!
!   C1        x-direction distance between local average centers is C1*Dx.
!             (input)
!
!   C2        y-direction distance between local average centers is C2*Dy.
!             (input)
!
! REVISION HISTORY:
! 1.1	now including a Gaussian Quadrature integration option as an
!	alternative to the variance function approach to evaluate
!	covariances between local averages. (Jun 16/00)
! 1.2	now choose between Gauss Quadrature and var function approaches
!	to minimize numerical errors. Eliminated lvarfn. (Mar 27/01)
! 1.3	use Gauss quadrature for everything (Apr 11/01)
!  1.4	now use 16-pt Gauss quadrature for increased accuracy (Apr 8/02)
!  1.5	simplification below only correct for areas completely overlapping
!	(Jul 2/03)
!---------------------------------------------------------------------------
      real*8 function dcvaa2( cov, Dx, Dy, C1, C2 )
      parameter (NG = 16)
      implicit real*8 (a-h,o-z)
      dimension w(NG), z(NG)

      external cov

      data zero/0.d0/, sx/0.0625d0/, quart/0.25d0/, half/0.5d0/
      data one/1.d0/, two/2.d0/

!			these are for NG = 3
!     data w/0.555555555555556d0,.888888888888889d0,.555555555555556d0/
!     data z/-.774596669241483d0,.000000000000000d0,.774596669241483d0/
!			and these are for NG = 5
!     data w/ .236926885056189d0,.478628670499366d0,.568888888888889d0,
!    >        .478628670499366d0,.236926885056189d0/
!     data z/-.906179845938664d0,-.538469310105683d0,.000000000000000d0,
!    >        .538469310105683d0, .906179845938664d0/
!			these are for NG = 16
      data w/0.027152459411754094852d0, 0.062253523938647892863d0,&
             0.095158511682492784810d0, 0.124628971255533872052d0,&
             0.149595988816576732081d0, 0.169156519395002538189d0,&
             0.182603415044923588867d0, 0.189450610455068496285d0,&
             0.189450610455068496285d0, 0.182603415044923588867d0,&
             0.169156519395002538189d0, 0.149595988816576732081d0,&
             0.124628971255533872052d0, 0.095158511682492784810d0,&
             0.062253523938647892863d0, 0.027152459411754094852d0/
      data z/-.989400934991649932596d0, -.944575023073232576078d0,&
             -.865631202387831743880d0, -.755404408355003033895d0,&
             -.617876244402643748447d0, -.458016777657227386342d0,&
             -.281603550779258913230d0, -.095012509837637440185d0,&
             0.095012509837637440185d0, 0.281603550779258913230d0,&
             0.458016777657227386342d0, 0.617876244402643748447d0,&
             0.755404408355003033895d0, 0.865631202387831743880d0,&
             0.944575023073232576078d0, 0.989400934991649932596d0/

      r1  = half*Dx
      r2  = half*Dy
!					if areas overlap, GQ simplifies

      if( (C1 .eq. zero) .and. (C2 .eq. zero) ) then

         d1 = zero
         do 20 i = 1, NG
            xi = r1*(one + z(i))
            d2 = zero
            do 10 j = 1, NG
               yi = r2*(one + z(j))
               d2 = d2 + w(j)*(one-z(j))*cov(xi,yi)
  10        continue
            d1 = d1 + w(i)*(one-z(i))*d2
  20     continue
         dcvaa2 = quart*d1
         return

      endif
!					otherwise, non-overlapping areas
      s1 = two*C1 - one
      s2 = two*C1 + one
      v1 = two*C2 - one
      v2 = two*C2 + one
      d1 = zero
      do 40 i = 1, NG
         xi1 = r1*(z(i) + s1)
         xi2 = r1*(z(i) + s2)
         d21 = zero
         d22 = zero
         do 30 j = 1, NG
            yi1 = r2*(z(j) + v1)
            yi2 = r2*(z(j) + v2)
            dz1 = one + z(j)
            dz2 = one - z(j)
            d21 = d21 + w(j)*(dz1*cov(xi1,yi1) + dz2*cov(xi1,yi2))
            d22 = d22 + w(j)*(dz1*cov(xi2,yi1) + dz2*cov(xi2,yi2))
  30     continue
         d1 = d1 + w(i)*((one+z(i))*d21 + (one-z(i))*d22)
  40  continue
      dcvaa2 = sx*d1

      return
      end


      subroutine dt2d_d(d1,d2,t3,dedt3d)

      implicit double precision(a-h,o-z)

      dimension d1(3),d2(3),t3(3,3,3),dedt3d(3)

c  this subroutine evaluates the derivatives of the dipole-dipole
c  electrostatic interaction

      dimension a(3,6),b(6)

      a(1,1)=t3(1,1,1)
      a(1,2)=t3(1,1,2)
      a(1,3)=t3(1,1,3)
      a(1,4)=t3(1,2,2)
      a(1,5)=t3(1,2,3)
      a(1,6)=t3(1,3,3)

      a(2,1)=t3(1,1,2)
      a(2,2)=t3(1,2,2)
      a(2,3)=t3(1,2,3)
      a(2,4)=t3(2,2,2)
      a(2,5)=t3(2,2,3)
      a(2,6)=t3(2,3,3)

      a(3,1)=t3(1,1,3)
      a(3,2)=t3(1,2,3)
      a(3,3)=t3(1,3,3)
      a(3,4)=t3(2,2,3)
      a(3,5)=t3(2,3,3)
      a(3,6)=t3(3,3,3)

      b(1)=d1(1)*d2(1)
      b(2)=d1(1)*d2(2)+d1(2)*d2(1)
      b(3)=d1(1)*d2(3)+d1(3)*d2(1)
      b(4)=d1(2)*d2(2)
      b(5)=d1(2)*d2(3)+d1(3)*d2(2)
      b(6)=d1(3)*d2(3)

      dedt3d(1)=a(1,1)*b(1)+a(1,2)*b(2)+a(1,3)*b(3)+a(1,4)*b(4)+
     .          a(1,5)*b(5)+a(1,6)*b(6)

      dedt3d(2)=a(2,1)*b(1)+a(2,2)*b(2)+a(2,3)*b(3)+a(2,4)*b(4)+
     .          a(2,5)*b(5)+a(2,6)*b(6)

      dedt3d(3)=a(3,1)*b(1)+a(3,2)*b(2)+a(3,3)*b(3)+a(3,4)*b(4)+
     .          a(3,5)*b(5)+a(3,6)*b(6)

      return
      end


Subroutine pbarfs(srt, npion, iseed)
  Parameter (pimass=0.140, pi=3.1415926)
  Dimension factor(6), pnpi(6)
  Common /rndf77/nseed
  Save
  factor(2) = 1.
  factor(3) = 1.17E-01
  factor(4) = 3.27E-03
  factor(5) = 3.58E-05
  factor(6) = 1.93E-07
  ene = (srt/pimass)**3/(6.*pi**2)
  Do n = 2, 6
    pnpi(n) = ene**n*factor(n)
  End Do
  pmax = max(pnpi(2), pnpi(3), pnpi(4), pnpi(5), pnpi(6))
  ntry = 0
  10 npion = 2 + int(5*ranart(nseed))
  If (npion>6) Goto 10
  thisp = pnpi(npion)/pmax
  ntry = ntry + 1
  If ((thisp<ranart(nseed)) .And. (ntry<=20)) Goto 10
  Return
End Subroutine pbarfs