      subroutine   furrow(
     i                    nowcrp,pkrmax,runmax,
     m                    rwdth)
c
c     + + + PURPOSE + + +
c     This subprogram controls a kinematic wave model for specified
c     space intervals using the Kostiakov-Lewis infiltration function.
c     Subprogram FURROW mimics subprogram IRS in developing equivalent
c     plane parameters.
c
c     Called from IRRIG
c     Author(s): E. R. Kottwitz.
c     Reference in User Guide: Chapter 12
c
c     Changes:
c
c     Version: This module recoded from WEPP Version 93.06.
c     Date recoded: 07/07/93.
c     Recoded by: Charles R. Meyer.
c
c     + + + PARAMETERS + + +
      include 'pmxelm.inc'
      include 'pmxcrp.inc'
      include 'pmxhil.inc'
      include 'pmxnsl.inc'
      include 'pmxpln.inc'
      include 'pmxres.inc'
      include 'pmxsrg.inc'
      include 'pmxtil.inc'
      include 'pmxtls.inc'
      include 'pntype.inc'
      include 'pxstep.inc'
c
c     + + + ARGUMENT DECLARATIONS + + +
      integer   nowcrp(mxplan)
      real      pkrmax,runmax,rwdth
c
c     + + + ARGUMENT DEFINITIONS + + +
c     nowcrp - number of current crop
c     pkrmax - maximum of the peak runoff rates of the overland flow
c              elements making up the equivalent plane (m/s)
c     runmax - maximum of the runoff values of the overland flow
c              elements making up the equivalent plane (m)
c     rwdth  - row width of overland flow element into which water is
c              introduced (m)
c
c     + + + COMMON BLOCKS + + +
      include 'cconsta.inc'
c       read: accgav
c
      include 'ccrpout.inc'
c       read: rh(mxplan)
c
      include 'ccrpprm.inc'
c       read: rw(mxcrop,mxplan)
c
      include 'cdist2.inc'
c       read: slplen(mxplan)
c
      include 'cefflen.inc'
c     modify: efflen(mxplan)
c
      include 'cends4.inc'
c       read: rspace(mxplan)
c
      include 'cffact.inc'
c       read: frctrl
c
      include 'chydrol.inc'
c     modify: runoff(mxplan)
c      write: effdrn(mxplan),peakro(mxplan)
c
      include 'ciraflo.inc'
c     modify: botwid,sidslp
c
      include 'cirfurr.inc'
c       read: depsrg(mxplan),endofe,nqsppl(mxsrg),ntend(mxsrg),
c             ntstrt(mxsrg),surges(mxplan)
c     modify: advdis,irqin,nsurge,qspply(mxplan),srg,surge,tend(mxsrg),
c             timtot,tstart(mxsrg),xpostn(0:xsteps)
c      write: aflow(0:xsteps,2),infltr(0:xsteps,2),infvlm(mxplan),
c             inoptm(0:xsteps),irslp,qflow(0:xsteps,2),srgflg,
c             tadvan(0:xsteps),timflg
c
      include 'cirriga.inc'
c       read: irofe,noirr
c
      include 'cprams2.inc'
c      write: norun(mxplan)
c
      include 'cslope2.inc'
c       read: avgslp(mxplan)
c
      include 'cstmflg.inc'
c       read: nmon
c
      include 'cstruc.inc'
c       read: nplane
c     modify: iplane
c
      include 'csumirr.inc'
c     modify: irrund(mxplan),irrunm(mxplan),irrunt(mxplan),
c             irruny(mxplan),
c
      include 'cslpopt.inc'
c     read: totlen
c
      include 'cupsfl.inc'
c
c     + + + LOCAL VARIABLES + + +
      integer   i,itemp,j,lipl,retflg
      real      chezch,deltax
c
c     + + + LOCAL DEFINITIONS + + +
c     i      - primary kinematic wave calculation counter
c     itemp  - maximum advance increment counter
c     j      - secondary kinematic wave calculation counter
c     lipl   - local overland flow element counter
c     retflg - flag indicating model status when returning from
c              subprograms FURADV and FURRUN (retflg=0: generate runoff
c              information and initial value, retflg=1: furrow
c              irrigation simulation is complete, retflg=2: process next
c              OFE, retflg=3: restart process using depletion level
c              irrigation parameters, retflg=4: process next surge).
c     chezch - Chezy friction coefficient (m**(0.5)/s)
c     deltax - distance increment (m)
c
c     + + + SUBROUTINES CALLED + + +
c     frcfac
c     furadv
c     furrun
c     irprnt
c     kostia
c
c     + + + END SPECIFICATIONS + + +
c
c     ----- INITIALIZE VARIABLES -----
c
c     The following runon - runoff cases can occur (cases numbered as in
c     sr irs).  Rainfall excess is 0 for all cases as irrigation on days
c     with rainfall is not supported by the model.
c
c     case 1 : q(iplane-1) =  0        q(iplane) = 0
c     case 3 : q(iplane-1) >  0        q(iplane) > 0
c     case 4 : q(iplane-1) >  0        q(iplane) = 0
c
c     Case 1 occurs for all planes above water supply point.
c
      irqin = 0.0
      do 100  iplane = 1, irofe-1
        norun(iplane) = 0
        infvlm(iplane) = 0.0
        runoff(iplane) = 0.0
        peakro(iplane) = 0.0
        effdrn(iplane) = 0.0
        efflen(iplane) = slplen(iplane)
c
c       Write "single storm" output.
c
        if(imodel.ne.1)call irprnt
  100 continue
c
c     Case 3 or case 4 for plane where water is introduced.  Note that
c     this plane is not a "true" case 3 or case 4 since there was no
c     runoff from the previous plane.
c
      norun(irofe) = 1
      runoff(irofe) = 0.0
      peakro(irofe) = 0.0
      effdrn(irofe) = 0.0
      efflen(irofe) = slplen(irofe)
c
c     Row width used for furrow irrigation is equal to the crop row
c     spacing unless this value is less than 0.2 meters.  The second
c     choice for row width is rill spacing.  If rill spacing is less
c     than 0.2 meters then set row width for furrow irrigation
c     calculations equal to 0.2 meters.
c
      if(rw(nowcrp(irofe),irofe).ge.0.2) then
        rwdth = rw(nowcrp(irofe),irofe)
      elseif(rspace(irofe).ge.0.2) then
        rwdth = rspace(irofe)
      else
        rwdth = 0.2
      endif
c
c     Estimate furrow geometry.  User will eventually be asked to
c     provide botwid and sidslp.  If values are not provided then these
c     equations (or similar ones) will be used to estimate botwid and
c     sidslp
c
      botwid = 0.25*rwdth
      sidslp = botwid/rh(irofe)
c
c     Variables to be initialized depend on the irrigation scheduling
c     alternative used.
c
      if(noirr.eq.2)then
c
c       For fixed date scheduling initialize surge and advdis.
c
        surge = surges(irofe)
        advdis = 0.0
      else
c
c       For depletion level scheduling, find advance distance for first
c       surge.
c
        advdis = 0.0
        do 200  iplane = irofe, endofe
          advdis = advdis+slplen(iplane)
  200   continue
        if(depsrg(irofe).ge.3)advdis = advdis/float(depsrg(irofe))
      endif
c
c     Reset iplane for furrow irrigation simulation.
c
      iplane = irofe
c
c     ----- INITIALIZE OFE SPECIFIC VARIABLES -----
c
c     Label 10 marks the position where control is passed after
c     incrementing to the next OFE.
c
   10 continue
c
c     Calculate roughness coefficient for the rill or furrow.
c
      call frcfac(nowcrp(iplane))
c
c      ---- (WEPP Equation 9.1.1 (NSERL Report No. 2))
      chezch = sqrt(8.0*accgav/frctrl(iplane))
c
c     Determine slope to be used for furrow irrigation.  Kinematic wave
c     analysis is limited to slopes >= 0.1%.
c
      irslp = max(0.001,avgslp(iplane))
c
c     Determine furrow geometry parameters (aqcnst and aqexp)
c
      call furgps(chezch)
c
c     If the following is true then calculate timtot and, possibly,
c     irqin.  Otherwise, timtot has already been estimated (depletion
c     level scheduling) and calculating irqin is not necessary.
c
   30 if(noirr.eq.2)then
        timtot = 0.0
        do 300  srg = 1, surge
          timtot = timtot+tend(srg)-tstart(srg)
c
c         Irqin has units of m^2/s (flow rate per unit width).
c
          if(iplane.eq.irofe)irqin = max(irqin,qspply(srg)/rwdth)
  300   continue
      endif
c
c     Obtain Kostiakov-Lewis infiltration function constants (kosta,
c     kostf, and kostk).
c
      call kostia(rwdth)
c
c     Write "single storm" output.
c
      if(imodel.ne.1)call irprnt
c
c     Reset flow area and infiltrated depth arrays.
c
      do 400  i = 0, xsteps
        aflow(i,1) = 0.0
        aflow(i,2) = 0.0
        qflow(i,1) = 0.0
        qflow(i,2) = 0.0
        infltr(i,1) = 0.0
        infltr(i,2) = 0.0
        tadvan(i) = 0.0
        trec(i) = 0.0
  400 continue
c
c     Initialize miscellaneous variables.
c
      itemp = 0
      srgflg = 0
      timflg = 0
      srg = 1
      tadvan(0) = tstart(srg)
c
c     Determine xpostn(0).
c
      if(iplane.eq.irofe)then
        xpostn(0) = 0.0
      else
        xpostn(0) = xpostn(xsteps)
      endif
c
c     Determine deltax and xpostn(xsteps).
c
      if(noirr.eq.1 .and. slplen(irofe)+xpostn(0).ge.advdis)then
        deltax = 1.5*(advdis-xpostn(0))/float(xsteps)
        xpostn(xsteps) = advdis
      else
        deltax = 1.5*slplen(iplane)/float(xsteps)
        xpostn(xsteps) = xpostn(0)+slplen(iplane)
      endif
c
c     Determine xpostn(1), xpostn(2),    , xpostn(xsteps-1)
c     and inoptm(0), inoptm(1),    , inoptm(xsteps-1) AND
c     inoptm(xsteps).
c
      inoptm(0) = 0.0
      do 500  j = 1, xsteps-1
        if(j.eq.xsteps/3+1)deltax = deltax/2.0
        inoptm(j) = 0.0
        xpostn(j) = xpostn(j-1)+deltax
  500 continue
      inoptm(xsteps) = 0.0
c
c     -----  ADVANCE PHASE  -----
c
c     Label 20 marks the position where control is passed when
c     incrementing the surge if depletion and recession occurred for the
c     previous surge.
c
   20 retflg = 0
      call furadv(rwdth,i,retflg)
c
c     The value of the variable retflg returned from FURADV indicates
c     next task (see explanation in local variables list)
c
      if(retflg.eq.1)then
        goto 9999
      elseif(retflg.eq.2)then
        goto 10
      elseif(retflg.eq.3)then
        goto 30
      endif
c
c     -----  GENERATE RUNOFF INFORMATION  -----
c
      call furrun(i,rwdth,itemp,pkrmax,runmax,retflg)
      if(retflg.eq.4)goto 20
c
c     If next statement is true then increment OFE counter, reinitialize
c     parameters where necessary, and pass control to label 10.
c
cd   Added by S. Dun April 04, 2004
      if((runoff(iplane).gt.0.000001).and. (iplane.le.(nplane-1))) then
          iuprun(iplane+1) = 1
      endif
cd   end adding
      if(nsurge.ne.0)then
        iplane = iplane+1
        surge = nsurge
        nsurge = 0
        norun(iplane) = 1
        runoff(iplane) = 0.0
        peakro(iplane) = 0.0
        effdrn(iplane) = 0.0
        efflen(iplane) = efflen(iplane-1)+slplen(iplane)
        do 600  srg = 1, surge
          qspply(srg) = nqsppl(srg)
          tend(srg) = ntend(srg)
          tstart(srg) = ntstrt(srg)
  600   continue
c
c       Write "single storm" output.
c
        if(imodel.ne.1)call irprnt
        goto 10
      endif
c
c     Case 1 occurs for all remaining planes.
c
      do 700  lipl = iplane+1, nplane
        norun(lipl) = 0
        runoff(lipl) = 0.0
        peakro(lipl) = 0.0
        effdrn(lipl) = 0.0
        efflen(lipl) = slplen(lipl)
        infvlm(lipl) = 0.0
  700 continue
c
c     Update variables of common block sumirr.
c
cd    Now the total irrigation attributed runoff depth is for
cd    the total length of the OFE which means counting from
cd     top of the hillslope
      do 800  lipl = 1, nplane
        irrund(lipl) = runoff(lipl)
        irrunt(lipl) = irrunt(lipl) + irrund(lipl)
     1    * efflen(iplane) / totlen(iplane)
        irruny(lipl) = irruny(lipl) + irrund(lipl)
     1    * efflen(iplane) / totlen(iplane)
        irrunm(lipl) = irrunm(lipl) + irrund(lipl)
     1    * efflen(iplane) / totlen(iplane)
  800 continue
c
 9999 return
      end


      subroutine runCP_00iii(i1,i2,i3,m0sq,Gr,Bzero3,N0)
      implicit none
      include 'TRconstants.f'
      include 'pvCnames.f'
      include 'pvCv.f'
      include 'Carraydef.f'
      include 'Carrays.f'
      integer ep,N0,i1,i2,i3,m,n,np
      parameter(np=2)
      double precision m0sq,Gr(np,np)
      double complex Bzero3(z3max,-2:0),bit,pole

      do ep=-2,0
      bit=czip
      do n=1,np
      do m=1,np
      bit=bit+Gr(n,m)*Cv(ciiiii(z5(n,m,i1,i2,i3))+N0,ep)
      enddo
      enddo

      pole=czip
      if (ep .gt. -2) pole=4d0*Cv(czziii(z3(i1,i2,i3))+N0,ep-1)

      Cv(czziii(z3(i1,i2,i3))+N0,ep)=
     . (pole
     . +2d0*Bzero3(z3(i1,i2,i3),ep)
     . +2d0*m0sq*Cv(ciii(z3(i1,i2,i3))+N0,ep)
     . -bit)/20d0
      enddo

      return
      end


!--------------------------------------------------------------------------------
! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany
! This file is part of FLEUR and available as free software under the conditions
! of the MIT license as expressed in the LICENSE file in more detail.
!--------------------------------------------------------------------------------

      MODULE m_od_chisym
      use m_juDFT
c*************************************************************
c     establishes the rotational matrices and translational
c     vectors in the case of one-dimensional calculations
c     according to the one-dimensional group of symmetries
c                           Y.Mokrousov 2003
c**********************************************
c     CHIRAL SYMMETRY GROUP
c     The main feature is that this group, been represented in 3D space,
c     is cyclic, with the generator <psi|tau> been simultaneous rotation
c     of the system by angle psi around z-axis and translation by tau
c     along z-direction. The input parameters, given to the program, are:
c          - M (odd%rot)
c          - N (odd%chi),
c     where N is the number of operations in the symmetry group, so that
c     psi = 2pi/N and M is some integer:tau = M/N in the internal units.

      CONTAINS
      SUBROUTINE od_chisym(odd,mrot,tau,zrfs,invs,invs2,amat)

      USE m_constants, ONLY : tpi_const
      USE m_types, ONLY : od_dim

      IMPLICIT NONE

      TYPE (od_dim), INTENT (IN) :: odd
      REAL, INTENT (IN) :: amat(3,3)
      LOGICAL, INTENT (IN) :: zrfs,invs,invs2
      REAL, INTENT (OUT) :: mrot(3,3,odd%nop),tau(3,odd%nop)

      INTEGER n,j,i,half

      tau(:,:) = 0.
      mrot(1:3,1:3,1:odd%nop) = 0.
      mrot(3,3,:) = 1.
      mrot(1,1,1) = 1.
      mrot(2,2,1) = 1.

      IF (.NOT.odd%invs .AND. .NOT.odd%zrfs) THEN
c for systems without z-reflection and inversion symmetries
        DO n = 2,odd%nop
         mrot(1,1,n) =  cos(tpi_const*(n-1)/odd%nop)
         mrot(1,2,n) =  sin(tpi_const*(n-1)/odd%nop)
         mrot(2,1,n) = -sin(tpi_const*(n-1)/odd%nop)
         mrot(2,2,n) =  cos(tpi_const*(n-1)/odd%nop)
         IF (odd%chi.NE.1) THEN
            tau(3,n) = tau(3,n-1) +
     +           amat(3,3)*(odd%rot)/(odd%chi)
            IF (abs(tau(3,n)-amat(3,3)).LE.1.e-4) THEN
               tau(3,n) = 0.
            ELSEIF (tau(3,n)-amat(3,3).GT.1.e-4) THEN
               tau(3,n) = tau(3,n) - amat(3,3)
            END IF
         END IF
        END DO
c for systems with inversion or z-relection symmetries
      ELSE
         half = NINT((odd%nop)/2.)
         IF ((odd%nop)/2. - half > 0.001) THEN
            CALL juDFT_error("nop =/= 2*n & (invs v zrfs) !",calledby
     +           ="od_chisym")
         ENDIF
         DO n = 2,half
            mrot(1,1,n) =  cos(tpi_const*(n-1)/half)
            mrot(1,2,n) =  sin(tpi_const*(n-1)/half)
            mrot(2,1,n) = -sin(tpi_const*(n-1)/half)
            mrot(2,2,n) =  cos(tpi_const*(n-1)/half)
         END DO
         IF (odd%zrfs) THEN
            mrot(1,1,half+1) =  1.
            mrot(2,2,half+1) =  1.
            mrot(3,3,half+1) = -1.
         ELSE IF (odd%invs) THEN
            mrot(1,1,half+1) = -1.
            mrot(2,2,half+1) = -1.
            mrot(3,3,half+1) = -1.
         END IF
         DO n = 2,half
           !CALL matmul3r(mrot(:,:,n),mrot(:,:,half+1),mrot(:,:,half+n))
           mrot(:,:,half+n)=matmul(mrot(:,:,n),mrot(:,:,half+1))
         END DO
      END IF
      RETURN
      END SUBROUTINE od_chisym
      END MODULE m_od_chisym


!
!  Copyright 2016 ARTED developers
!
!  Licensed under the Apache License, Version 2.0 (the "License");
!  you may not use this file except in compliance with the License.
!  You may obtain a copy of the License at
!
!      http://www.apache.org/licenses/LICENSE-2.0
!
!  Unless required by applicable law or agreed to in writing, software
!  distributed under the License is distributed on an "AS IS" BASIS,
!  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
!  See the License for the specific language governing permissions and
!  limitations under the License.
!
subroutine init_Ac_ms_basis_expansion
  use global_variables
  use ms_maxwell_ks_variables
  implicit none
  integer :: iter, ix
  real(8) :: tt
  real(8) :: f0_1,f0_2,omega_1,omega_2,tpulse_1,tpulse_2,T1_T2

  if(myrank == 0)write(*,"(A)")"== Start: Initialization of vector potential."
  allocate(Ac_m(nx_s:nx_e), jt_m(Mx))
  allocate(jt_old_m(Mx), jt_old2_m(Mx))
  allocate(Ac_m_n(nx_s:nx_e), Ac_m_o(nx_s:nx_e))
  allocate(x_m(nx_s:nx_e))

  do ix = nx_s, nx_e
    x_m(ix) = ix*dx_m -0.5d0*dx_m
  end do

  Ac_m = 0d0
  Ac_m_o = 0d0

  f0_1=5.338d-9*sqrt(IWcm2_1)      ! electric field in a.u.
  omega_1=omegaev_1/(2d0*Ry)  ! frequency in a.u.
  tpulse_1=tpulsefs_1/0.024189d0 ! pulse duration in a.u.
  f0_2=5.338d-9*sqrt(IWcm2_2)      ! electric field in a.u.
  omega_2=omegaev_2/(2d0*Ry)  ! frequency in a.u.
  tpulse_2=tpulsefs_2/0.024189d0 ! pulse duration in a.u.
  T1_T2=T1_T2fs/0.024189d0 ! pulse duration in a.u.

  select case(laser_type)
  case('cos2cos')
! pump
    do ix = nx_s, nx_e

!t=0
      tt = 0d0 -x_m(ix)/clight-0.5d0*tpulse_1
      if(abs(tt)<0.5d0*tpulse_1)then
        Ac_m(ix) = -f0_1/omega_1*cos(pi*tt/tpulse_1)**2*sin(omega_1*tt)
      end if

!t=-dt
      tt = -dt_m -x_m(ix)/clight-0.5d0*tpulse_1
      if(abs(tt)<0.5d0*tpulse_1)then
        Ac_m_o(ix) = -f0_1/omega_1*cos(pi*tt/tpulse_1)**2*sin(omega_1*tt)
      end if

    end do
! pump
    do ix = nx_s, nx_e

!t=0
      tt = 0d0 -x_m(ix)/clight-0.5d0*tpulse_1 - T1_T2
      if(abs(tt)<0.5d0*tpulse_2)then
        Ac_m(ix) = Ac_m(ix) -f0_2/omega_2*cos(pi*tt/tpulse_2)**2*sin(omega_2*tt)
      end if

      tt = -dt_m -x_m(ix)/clight-0.5d0*tpulse_1 - T1_T2
      if(abs(tt)<0.5d0*tpulse_2)then
        Ac_m_o(ix) = Ac_m_o(ix) -f0_2/omega_2*cos(pi*tt/tpulse_2)**2*sin(omega_2*tt)
      end if

    end do

  case('cos4cos')
! pump
    do ix = nx_s, nx_e

!t=0
      tt = 0d0 -x_m(ix)/clight-0.5d0*tpulse_1
      if(abs(tt)<0.5d0*tpulse_1)then
        Ac_m(ix) = -f0_1/omega_1*cos(pi*tt/tpulse_1)**4*sin(omega_1*tt)
      end if

!t=-dt
      tt = -dt_m -x_m(ix)/clight-0.5d0*tpulse_1
      if(abs(tt)<0.5d0*tpulse_1)then
        Ac_m_o(ix) = -f0_1/omega_1*cos(pi*tt/tpulse_1)**4*sin(omega_1*tt)
      end if

    end do
! pump
    do ix = nx_s, nx_e

!t=0
      tt = 0d0 -x_m(ix)/clight-0.5d0*tpulse_1 - T1_T2
      if(abs(tt)<0.5d0*tpulse_2)then
        Ac_m(ix) = Ac_m(ix) -f0_2/omega_2*cos(pi*tt/tpulse_2)**4*sin(omega_2*tt)
      end if

      tt = -dt_m -x_m(ix)/clight-0.5d0*tpulse_1 - T1_T2
      if(abs(tt)<0.5d0*tpulse_2)then
        Ac_m_o(ix) = Ac_m_o(ix) -f0_2/omega_2*cos(pi*tt/tpulse_2)**4*sin(omega_2*tt)
      end if

    end do
  case('Acos2_4')
! pump
    do ix = nx_s, nx_e

!t=0
      tt = 0d0 -x_m(ix)/clight-0.5d0*tpulse_1
      if(abs(tt)<0.5d0*tpulse_1)then
        Ac_m(ix) = -f0_1/omega_1*cos(pi*tt/tpulse_1)**2*sin(omega_1*tt)
      end if

!t=-dt
      tt = -dt_m -x_m(ix)/clight-0.5d0*tpulse_1
      if(abs(tt)<0.5d0*tpulse_1)then
        Ac_m_o(ix) = -f0_1/omega_1*cos(pi*tt/tpulse_1)**2*sin(omega_1*tt)
      end if

    end do
! pump
    do ix = nx_s, nx_e

!t=0
      tt = 0d0 -x_m(ix)/clight-0.5d0*tpulse_1 - T1_T2
      if(abs(tt)<0.5d0*tpulse_2)then
        Ac_m(ix) = Ac_m(ix) -f0_2/omega_2*cos(pi*tt/tpulse_2)**4*sin(omega_2*tt)
      end if

      tt = -dt_m -x_m(ix)/clight-0.5d0*tpulse_1 - T1_T2
      if(abs(tt)<0.5d0*tpulse_2)then
        Ac_m_o(ix) = Ac_m_o(ix) -f0_2/omega_2*cos(pi*tt/tpulse_2)**4*sin(omega_2*tt)
      end if

    end do
  case default
    err_message='error in init_Ac'
    call err_finalize
  end select

  if(myrank == 0)write(*,"(A)")"== End: Initialization of vector potential."

  return
end subroutine init_Ac_ms_basis_expansion


      SUBROUTINE GNDIPT(DEPEND)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      REAL*8 J2,J3,J4,J22
C
C
C     SUBROUTINE GNDIPT SETS UP THE DIRECTION COSINE MATRIX
C     BETWEEN THE BODY REFERENCE FRAME AND THE LOCAL GEOGRAPHICAL
C     INERTIAL FRAME. IT ALSO COMPUTES THE LOCAL VERTICAL ACCELERATION
C     VECTOR FROM THE INPUT ALTITUDE
C
C     IT IS WRITTEN BY K. YONG OF COMPUTER SCIENCES CORP. IN
C     MARCH 1976 TO HANDLE THE FSD GROUND TESTING SIMULATION
C     CAPABILITY
C
C
C     EXISTING FSD COMMON BLOCKS
C
      COMMON/CNBODY/J2,J3,J4,J22,ZJ20,ZMU,WWO,FLAT,AEARTH
C
      COMMON/CONSTS/PI,TWOPI,RADIAN
C
      COMMON/IMAIN1/ IDATE,LSAVE,INOPT,IPLOT,NUMEQS,IPLTPE,IORB,ITAPE
C
      COMMON/IPOOL1/IGRAV,IDAMP,IDUMY(37)
C
      COMMON/LIBDPR/ZK1D,ZK2D,PHIS,PHILD,DPHILD,BELTD,
     *        GAMLD,ZMDO,ZMBDO,CNV,DECAY
C
      COMMON/RPOOL1/RHOK(10),TIME,SA(3,3),FM1(3,3),ZLK(10),
     *      OMEG(3),ZLKP(10),ZLKDP(10),CMAT(3,3),GBAR(3,3),
     *      YBCM(3),ZBZK(3,10),FCM(3,3),DTO,PHID,PHI
C
      COMMON/RPOOL6/FM(3,3),CIY(3,3),CIZ(3,3),SAT(3,3),SZ1,SZ2,SZ3
C
C     NEW COMMON BLOCKS
C
      COMMON/GRNTST/ALFAEG,DELTAG,PHASEG,ALTUDE,OMGY(3),
     *              GACC(3),GLOCAT(3),IGRUND,IALTUD,IGASBR
C
      COMMON/GMATRX/GMAX(3,3),GMAXT(3,3)
C
      DIMENSION DEPEND(150),OMRB(3)
C
C
C     SET THE FLAGS TO ZERO FOR GROUND TESTING SIMULATION
C
      INOPT=0
      IGRAV=0
      DO 40 I=1,3
      DO 40 J=1,3
      GMAX(I,J)=0.0D0
 40   GMAXT(I,J)=0.0D0
C
C     COMPUTE THE ACCELERATION OF GRAVITY ALONG LOCAL VERTICAL
      IF(IALTUD.EQ.0) GO TO 5
      GACC(3)=(ZMU/(AEARTH+ALTUDE)**2)*3280.8D0
 5    CONTINUE
C
      DE=DELTAG*RADIAN
      AL=ALFAEG*RADIAN
C
      SDE=DSIN(DE)
      CDE=DCOS(DE)
      SAL=DSIN(AL)
      CAL=DCOS(AL)
C
C
C     CONSTRUCT THE DIRECTION COSINE MATRIX
C
      GMAX(1,1) =CAL
      GMAX(1,2) =SAL*CDE
      GMAX(1,3) =SAL*SDE
C
      GMAX(2,1) =-SAL
      GMAX(2,2) =CAL*CDE
      GMAX(2,3) =CAL*SDE
C
      GMAX(3,1) = 0.0D0
      GMAX(3,2) =-SDE
      GMAX(3,3) =CDE
C
C
      DO 10 I=1,3
      OMEG(I)=OMGY(I)*RADIAN
      OMRB(I)=OMEG(I)
      DO 10 J=1,3
      SA(I,J)= GMAX(I,J)
      GMAXT(I,J)=GMAX(J,I)
      SAT(I,J)= SA(J,I)
 10   CONTINUE
C
      L=0
      DO 20 I=1,2
      DO 20 J=1,3
      L=L+1
 20   DEPEND(L)=SA(I,J)
      DO 30 I=1,3
      L=I+6
 30   DEPEND(L)=OMRB(I)
C
      CALL ECHOGD
      IF(IDAMP.EQ.0) RETURN
      PHI=PHILD*RADIAN
      PHID=DPHILD*RADIAN
      DEPEND(10)=PHI
      DEPEND(11)=PHID
      RETURN
      END


      subroutine  grids ( ecv, xmu, negx, neg, emg , step, nflrx)
c     makes a grid in complex e-plane for scmt calculation
c     add complications for complex cases later. ala
c     emg is comlex energy in hartrees
      implicit double precision (a-h, o-z)

      complex*16 emg(negx), eim, eimmin
      dimension step(nflrx)
      include '../HEADERS/const.h'

c     the choice of e_cv should be automated later
c     all l-dos should be zero at ecv
c     fix it by hand if needed below
c     for some complicated materials may need multiple e_cv
c     it may also depend on core-valence separation

c     eimmin = the lowest im energy to search for fermi level
c     may simulate Fermi distr for occ numbers, thus may want
c     to lower eimmin for low temperatures.
      eimmin = coni*0.05/hart
      neg1 = (nflrx+1)/2
      neg3 = nflrx - 1
      neg2mx = negx-neg1-neg3
c     never do calculations on real axis.
      eim = eimmin*neg1**2
      eim = eimmin
      de = dimag(eim)/4

      do 10 i =1, neg1
c        step linearly increases as one get farther from real axis
         eim = eimmin *i**2
         emg(i) = ecv +eim
  10  continue
      step(nflrx) = dimag(eim)/4

c     set energy step for integration eim above real axis
      de = dimag(emg(neg1))/4
      neg2= nint((xmu-ecv)/de)
      if (neg2.gt.neg2mx) neg2=neg2mx
      if (neg2.lt.neg1) neg2 = neg1
      de = (xmu-ecv) / neg2
      do 20 i = neg1+1,neg1+neg2
  20  emg(i) = emg(i-1) + de

      neg = neg1 + neg2 + neg3
      do 30 i =1, neg3
c        step linearly increases as one get farther from real axis
         eim = eimmin *(i+1)**2 /4.d0
         if (i.le.nflrx) step(i) = dimag(eim)/4
         emg(neg-i+1) = xmu + eim
  30  continue

      return
      end


module aero
  implicit none

  private :: calcA_solution, calcA_YU

  interface calcA
    module procedure calcA_YU
    module procedure calcA_Solution
  end interface

  contains

    ! pure subroutine getAeroCoeffs(alpha3, U, D, Cf, Cm, Cm_damping)
    pure subroutine getAeroCoeffs(alpha3, omega3, apparent_velocity, Cf, Cm, problem)
      use transformation
      use types
      use math
      real*8, intent(in), dimension(3) :: omega3 !< Angular velocity solution
      real*8, intent(in) :: alpha3 !< Angle of Attack
      real*8, intent(in) :: apparent_velocity !< Linear velocity Magnitude
      type(problemData), intent(in) :: problem
      real*8, intent(out), dimension(3) :: Cf, Cm !< Vector of force and moment coefficients
      real*8 :: damping_factor

      Cf = 0d0
      Cm = 0d0

      Cf(1) = -(3.3d0*(alpha3 + 0.052)**2 + 0.085d0) ! drag
      Cf(2) = 0d0  ! side
      Cf(3) = -(3.09d0*alpha3 + 0.13d0) ! lift

      damping_factor = problem%disc%D/(2*apparent_velocity)
      Cm(1) = problem%disc%Cm_damping(1)*omega3(1)*damping_factor ! rolling moment
      Cm(2) = 0.057*alpha3 - 0.01 + problem%disc%Cm_damping(2)*omega3(2)*damping_factor ! pitching moment
      ! Cm(2) = 1d-3 ! pitching moment
      Cm(3) = problem%disc%Cm_damping(3)*omega3(3)*damping_factor ! yawing moment (ie. resisting spin)
    end subroutine getAeroCoeffs

    pure subroutine calcA_YU(Y, U, problem, A, dAdU)
      use types
      use transformation
      use math

      real*8, dimension(6), intent(in), target :: Y, U
      type(problemData), intent(in):: problem
      real*8, intent(out) :: A(6), dAdU(6,6)

      real*8, dimension(3) :: Cf, Cm, Iinv
      real*8, dimension(3) :: F4, M4, F2, M2
      real*8, dimension(3,3) :: Ta12, Ta34, Ta42, Tr12
      real*8, dimension(3,3) :: Ta32
      real*8, dimension(3,3) :: F_factor, M_factor
      real*8, dimension(3,6) :: J_Cm, J_Cf
      real*8 :: beta2, alpha3
      real*8 :: wind2(3), wind3(3)
      real*8, pointer :: vel2(:)
      real*8 :: vel3(3)
      integer :: i, j

      Ta12 = T_a12(Y(4:6))
      wind2 = transpose(Ta12).matmul.problem%env%wind
      beta2 = ATAN2( (U(2) - wind2(2)), (U(1) - wind2(1)) )

      Ta32 = transpose(T_a23(beta2))
      wind3 = Ta32.matmul.wind2
      vel3 = Ta32.matmul.U(1:3)
      alpha3 = ATAN2( (vel3(3) - wind3(3)), (vel3(1) - wind3(1)) )

      Ta34 = T_a34(alpha3)
      Ta42 = Ta32.matmul.transpose(Ta34)

      associate(omega3 => wind2, apparent_velocity => beta2)
        omega3 = Ta32.matmul.U(4:6)
        apparent_velocity = norm2(U(1:3) - problem%env%wind)

        call getAeroCoeffs(alpha3, omega3, apparent_velocity, Cf, Cm, problem)

        dynpress: associate(q=> alpha3)
          q = 0.5*problem%env%density*apparent_velocity**2! dynamic pressure

          F4(:) = q*problem%disc%A*Cf(:)
          M4(:) = q*problem%disc%A*problem%disc%D*Cm(:)
        end associate dynpress

        F2 = (Ta42.matmul.F4) + (transpose(Ta12).matmul.problem%env%gravity)*problem%disc%m
        M2 = Ta42.matmul.M4

        Iinv = (problem%disc%I**(-1))
        A(:3) = F2/problem%disc%m
        A(4:) = M2*Iinv

        ! Calculating A contribution to Tangent Matrix (ie. dAdU)
        F_factor = 0.5d0*problem%env%density*problem%disc%A*Ta42
        M_factor = F_factor

        F_factor = F_factor/problem%disc%m
        M_factor = M_factor*problem%disc%D

        call calcCfJacobian(Ta32, problem, U, J_Cf)
        call calcCmJacobian(Ta32, apparent_velocity, omega3, problem, U, problem%disc%Cm_damping, J_Cm)
      end associate

      associate(Fkj => J_Cf, Mkj => J_Cm, velocity => beta2)
        velocity = norm2(U(1:3))
        Fkj = Fkj*velocity**2
        Mkj = Mkj*velocity**2

        forall(i=1:3, j=1:3) Fkj(i,j) = Fkj(i,j) + 2*Cf(i)*U(j)
        forall(i=1:3, j=1:3) Mkj(i,j) = Mkj(i,j) + 2*Cm(i)*U(j)

        dAdU(1:3,:) = F_factor.matmul.Fkj
        dAdU(4:6,:) = M_factor.matmul.Mkj
      end associate

    end subroutine

    pure subroutine calcA_solution(solution, problem, A, dAdU)
      use types

      type(solution_state), intent(in) :: solution
      type(problemData), intent(in):: problem
      real*8, intent(out) :: A(6), dAdU(6,6)
      real*8, dimension(6):: Y, U

      Y = solution%Y
      U = solution%U

      call calcA_YU(Y, U, problem, A, dAdU)

    end subroutine

    pure subroutine calcCmJacobian(Ta32, apparent_velocity, omega3, problem, U, Cm_damping, J_Cm)
      use math
      use types, only: problemData
      real*8, intent(in) :: U(6), Cm_damping(3)
      type(problemData), intent(in) :: problem
      real*8, intent(in):: omega3(3), apparent_velocity
      real*8, dimension(3,3), intent(in) :: Ta32
      real*8, intent (out) :: J_Cm(3,6)
      integer :: i

      forall(i=1:3) J_Cm(i,1:3) = U(1:3)*Cm_damping(i)*omega3(i)*problem%disc%D/apparent_velocity**3
      forall(i=1:3) J_Cm(i,4:6) = 0.5d0*Ta32(i,:)*Cm_damping(i)*problem%disc%D*apparent_velocity
    end subroutine

    pure subroutine calcCfJacobian(Ta32, problem, U, J_Cf)
      use math
      use types, only: problemData
      real*8, intent(in) :: Ta32(3,3), U(6)
      type(problemData), intent(in) :: problem
      real*8, intent (out) :: J_Cf(3,6)

      J_Cf = 0
    end subroutine

end module aero


Subroutine xphib(lb1, lb2, em1, em2, srt, xsk1, xsk2, xsk3, xsk4, xsk5, sigp)
  Parameter (maxstr=150001, maxr=1, amn=0.939457, amp=0.93828, ap1=0.13496, ap2=0.13957, am0=1.232, pi=3.1415926)
  Parameter (aka=0.498, ala=1.1157, pimass=0.140, aphi=1.02)
  Parameter (arho=0.77)
  Save
  sigp = 1.E-08
  xsk1 = 0.0
  xsk2 = 0.0
  xsk3 = 0.0
  xsk4 = 0.0
  xsk5 = 0.0
  xsk6 = 0.0
  srrt = srt - (em1+em2)
  xsk1 = 8.00
  If (srt>(ap1+amn)) Then
    xsk2 = 0.0235*srrt**(-0.519)
  End If
  If (srt>(ap1+am0)) Then
    If (srrt<0.7) Then
      xsk3 = 0.0119*srrt**(-0.534)
    Else
      xsk3 = 0.0130*srrt**(-0.304)
    End If
  End If
  If (srt>(arho+amn)) Then
    If (srrt<0.7) Then
      xsk4 = 0.0166*srrt**(-0.786)
    Else
      xsk4 = 0.0189*srrt**(-0.277)
    End If
  End If
  If (srt>(arho+am0)) Then
    If (srrt<0.7) Then
      xsk5 = 0.0119*srrt**(-0.534)
    Else
      xsk5 = 0.0130*srrt**(-0.304)
    End If
  End If
  If ((lb1>=1 .And. lb1<=2) .Or. (lb2>=1 .And. lb2<=2)) Then
    If (srt>(aka+ala)) Then
      xsk6 = 1.715/((srrt+3.508)**2-12.138)
    End If
  End If
  sigp = xsk1 + xsk2 + xsk3 + xsk4 + xsk5 + xsk6
  Return
End Subroutine xphib


      INTEGER FUNCTION JLIYMD (JUL,IYR,IMON,IDAY)
C
      INTEGER*4 JUL, IYMDJL, IBASE, JUL2, JULB, JULC                    ML
      DATA IBASE /693960/
C
      JLIYMD = 0
C
      JULC=JUL+IBASE
      IYR=FLOAT(JULC)/365.2425
      IF (IYR.LT.0) GO TO 80
      DO 5 I=1,20
      JUL2=IYMDJL(IYR,1,1)
      IF(JUL2.GT.JUL) GO TO 7
      IYR=IYR+1
5     CONTINUE
      GO TO 80
C
7     IYR=IYR-1
      JULB=IYMDJL(IYR,1,1)
      JA=MIN0(12,(JUL-JULB+28)/28)
      DO 10 IMON=JA,12
      JUL2=IYMDJL(IYR,IMON,1)
      IF(JUL2.GT.JUL) GO TO 20
10    CONTINUE
      IMON=13
 20   IMON=IMON-1
      JUL2=IYMDJL(IYR,IMON,1)
      IDAY=JUL-JUL2+1
      GO TO 90
C
C     Invalid julian day, error
80    JLIYMD = -1
      IYR = 0
      IMON = 0
      IDAY = 0
C
90    CONTINUE
      RETURN
      END


      SUBROUTINE MB03FD( N, PREC, A, LDA, B, LDB, Q1, LDQ1, Q2, LDQ2,
     $                   DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute orthogonal matrices Q1 and Q2 for a real 2-by-2 or
C     4-by-4 regular pencil
C
C                   ( A11  0  )     (  0  B12 )
C       aA - bB = a (         ) - b (         ),                     (1)
C                   (  0  A22 )     ( B21  0  )
C
C     such that Q2' A Q1 is upper triangular, Q2' B Q1 is upper quasi-
C     triangular, and the eigenvalues with negative real parts (if there
C     are any) are allocated on the top. The notation M' denotes the
C     transpose of the matrix M. The submatrices A11, A22, and B12 are
C     upper triangular. If B21 is 2-by-2, then all the other blocks are
C                                    -1        -1
C     nonsingular and the product A11   B12 A22   B21 has a pair of
C     complex conjugate eigenvalues.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the input pencil, N = 2 or N = 4.
C
C     PREC    (input) DOUBLE PRECISION
C             The machine precision, (relative machine precision)*base.
C             See the LAPACK Library routine DLAMCH.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA, N)
C             On entry, the leading N-by-N part of this array must
C             contain the matrix A of the pencil aA - bB.
C             If N = 2, the diagonal elements only are referenced.
C             On exit, if N = 4, the leading N-by-N part of this array
C             contains the transformed upper triangular matrix of the
C             generalized real Schur form of the pencil aA - bB.
C             If N = 2, this array is unchanged on exit.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= N.
C
C     B       (input/output) DOUBLE PRECISION array, dimension (LDB, N)
C             On entry, the leading N-by-N part of this array must
C             contain the matrix B of the pencil aA - bB.
C             If N = 2, the anti-diagonal elements only are referenced.
C             On exit, if N = 4, the leading N-by-N part of this array
C             contains the transformed real Schur matrix of the
C             generalized real Schur form of the pencil aA - bB.
C             If N = 2, this array is unchanged on exit.
C
C     LDB     INTEGER
C             The leading dimension of the array B.  LDB >= N.
C
C     Q1      (output) DOUBLE PRECISION array, dimension (LDQ1, N)
C             The leading N-by-N part of this array contains the first
C             orthogonal transformation matrix.
C
C     LDQ1    INTEGER
C             The leading dimension of the array Q1.  LDQ1 >= N.
C
C     Q2      (output) DOUBLE PRECISION array, dimension (LDQ2, N)
C             The leading N-by-N part of this array contains the second
C             orthogonal transformation matrix.
C
C     LDQ2    INTEGER
C             The leading dimension of the array Q2.  LDQ2 >= N.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             If N = 2, then DWORK is not referenced.
C
C     LDWORK  INTEGER
C             The dimension of the array DWORK.
C             If N = 4, then LDWORK >= 63. For good performance LDWORK
C             should be generally larger.
C             If N = 2, then LDWORK >= 0.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0: succesful exit;
C             = 1: the QZ iteration failed in the LAPACK routine DGGES;
C             = 2: another error occured during execution of DGGES.
C
C     METHOD
C
C     The algorithm uses orthogonal transformations as described on page
C     29 in [2].
C
C     REFERENCES
C
C     [1] Benner, P., Byers, R., Mehrmann, V. and Xu, H.
C         Numerical computation of deflating subspaces of skew-
C         Hamiltonian/Hamiltonian pencils.
C         SIAM J. Matrix Anal. Appl., 24 (1), pp. 165-190, 2002.
C
C     [2] Benner, P., Byers, R., Losse, P., Mehrmann, V. and Xu, H.
C         Numerical Solution of Real Skew-Hamiltonian/Hamiltonian
C         Eigenproblems.
C         Tech. Rep., Technical University Chemnitz, Germany,
C         Nov. 2007.
C
C     NUMERICAL ASPECTS
C
C     The algorithm is numerically backward stable.
C
C     CONTRIBUTOR
C
C     Matthias Voigt, Fakultaet fuer Mathematik, Technische Universitaet
C     Chemnitz, October 16, 2008.
C
C     REVISIONS
C
C     V. Sima, Aug. 2009 (SLICOT version of the routine MB03FD).
C     V. Sima, Oct. 2009, Nov. 2009, Oct. 2010, Nov. 2010, Mar. 2016,
C     Mai 2016.
C     M. Voigt, Jan. 2012.
C
C     KEYWORDS
C
C     Eigenvalue exchange, matrix pencil, upper (quasi-)triangular
C     matrix.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
C
C     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LDB, LDQ1, LDQ2, LDWORK, N
      DOUBLE PRECISION   PREC
C
C     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), DWORK( * ),
     $                   Q1( LDQ1, * ), Q2( LDQ2, * )
C
C     .. Local Scalars ..
      INTEGER            IDUM, IERR, IHI, ILO
      DOUBLE PRECISION   A11, A22, B12, B21, CO, SAFMIN, SCALA, SCALB,
     $                   SI, TMP
C
C     .. Local Arrays ..
      LOGICAL            BWORK( 4 )
      DOUBLE PRECISION   AS( 4, 4 ), BS( 4, 4 ), C( 4 ), R( 4 )
C
C     .. External Functions ..
      LOGICAL            SB02OW
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           DLAMCH, SB02OW
C
C     .. External Subroutines ..
      EXTERNAL           DGGBAK, DGGES, DLACPY, DLARTG, MB04DL
C
C     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, SIGN, SQRT
C
C     .. Executable Statements ..
C
C     For efficiency, the input arguments are not tested.
C
C     Computations.
C
      IF( N.EQ.4 ) THEN
C
C        Save A and B, since DGGES might not converge.
C
         CALL DLACPY( 'Full', N, N, A, LDA, AS, 4 )
         CALL DLACPY( 'Full', N, N, B, LDB, BS, 4 )
         CALL DGGES(  'Vector Computation', 'Vector Computation',
     $                'Sorted', SB02OW, N, B, LDB, A, LDA, IDUM, DWORK,
     $                DWORK( N+1 ), DWORK( 2*N+1 ), Q2, LDQ2, Q1, LDQ1,
     $                DWORK( 3*N+1 ), LDWORK-3*N, BWORK, INFO )
         IF( INFO.NE.0 ) THEN
C
C           Retry after balancing.
C
            CALL DLACPY( 'Full', N, N, AS, 4, A, LDA )
            CALL DLACPY( 'Full', N, N, BS, 4, B, LDB )
            CALL MB04DL( 'Both', N, ZERO, B, LDB, A, LDA, ILO, IHI, C,
     $                   R, DWORK, IDUM, IERR )
            CALL DGGES(  'Vector Computation', 'Vector Computation',
     $                   'Sorted', SB02OW, N, B, LDB, A, LDA, IDUM,
     $                   DWORK, DWORK( N+1 ), DWORK( 2*N+1 ), Q2, LDQ2,
     $                   Q1, LDQ1, DWORK( 3*N+1 ), LDWORK-3*N, BWORK,
     $                   IERR )
C
C           If DGGES fails again, error return based on previous call.
C
            IF( IERR.NE.0 ) THEN
               IF( INFO.GE.1 .AND. INFO.LE.4 ) THEN
                  INFO = 1
               ELSE
                  INFO = 2
               END IF
               RETURN
            END IF
            CALL DGGBAK( 'Both', 'Right', N, ILO, IHI, C, R, N, Q1,
     $                   LDQ1, INFO )
            CALL DGGBAK( 'Both', 'Left',  N, ILO, IHI, C, R, N, Q2,
     $                   LDQ2, INFO )
         END IF
      ELSE
         INFO = 0
C
C        Set Q1, and Q2 to I_2, or permuted I_2, if there are 0, purely
C        imaginary, or infinite eigenvalues.
C
         A11 = ABS( A( 1, 1 ) )
         A22 = ABS( A( 2, 2 ) )
         B21 = ABS( B( 2, 1 ) )
         B12 = ABS( B( 1, 2 ) )
C
         SAFMIN = DLAMCH( 'Safe minimum' )
         SCALA  = ONE / MAX( A11, A22, SAFMIN )
         SCALB  = ONE / MAX( B12, B21, SAFMIN )
C
         A11 = SCALA*A11
         A22 = SCALA*A22
         B21 = SCALB*B21
         B12 = SCALB*B12
         IF( A11.LE.PREC ) THEN
            Q1( 1, 1 ) = ONE
            Q1( 2, 1 ) = ZERO
            Q1( 1, 2 ) = ZERO
            Q1( 2, 2 ) = ONE
            Q2( 1, 1 ) = ZERO
            Q2( 2, 1 ) = ONE
            Q2( 1, 2 ) = ONE
            Q2( 2, 2 ) = ZERO
         ELSE IF( A22.LE.PREC ) THEN
            Q1( 1, 1 ) = ZERO
            Q1( 2, 1 ) = ONE
            Q1( 1, 2 ) = ONE
            Q1( 2, 2 ) = ZERO
            Q2( 1, 1 ) = ONE
            Q2( 2, 1 ) = ZERO
            Q2( 1, 2 ) = ZERO
            Q2( 2, 2 ) = ONE
         ELSE IF( B21.LE.PREC ) THEN
            Q1( 1, 1 ) = ONE
            Q1( 2, 1 ) = ZERO
            Q1( 1, 2 ) = ZERO
            Q1( 2, 2 ) = ONE
            Q2( 1, 1 ) = ONE
            Q2( 2, 1 ) = ZERO
            Q2( 1, 2 ) = ZERO
            Q2( 2, 2 ) = ONE
         ELSE IF( B12.LE.PREC ) THEN
            Q1( 1, 1 ) = ZERO
            Q1( 2, 1 ) = ONE
            Q1( 1, 2 ) = ONE
            Q1( 2, 2 ) = ZERO
            Q2( 1, 1 ) = ZERO
            Q2( 2, 1 ) = ONE
            Q2( 1, 2 ) = ONE
            Q2( 2, 2 ) = ZERO
         ELSE
            IF( SIGN( ONE, A( 1, 1 ) )*SIGN( ONE, A( 2, 2 ) )*
     $          SIGN( ONE, B( 2, 1 ) )*SIGN( ONE, B( 1, 2 ) ).GT.ZERO
     $        ) THEN
C
C              The pencil has two real eigenvalues.
C
               CALL DLARTG( SIGN( ONE, A( 1, 1 )*A( 2, 2 ) )*
     $                      SQRT( A22*B12 ), SQRT( A11*B21 ), CO, SI,
     $                      TMP )
               Q1( 1, 1 ) =  CO
               Q1( 2, 1 ) = -SI
               Q1( 1, 2 ) =  SI
               Q1( 2, 2 ) =  CO
               CALL DLARTG( SQRT( A11*B12 ), SQRT( A22*B21 ), CO, SI,
     $                      TMP )
               Q2( 1, 1 ) =  CO
               Q2( 2, 1 ) = -SI
               Q2( 1, 2 ) =  SI
               Q2( 2, 2 ) =  CO
            ELSE
               Q1( 1, 1 ) = ONE
               Q1( 2, 1 ) = ZERO
               Q1( 1, 2 ) = ZERO
               Q1( 2, 2 ) = ONE
               Q2( 1, 1 ) = ONE
               Q2( 2, 1 ) = ZERO
               Q2( 1, 2 ) = ZERO
               Q2( 2, 2 ) = ONE
            END IF
         END IF
      END IF
C
      RETURN
C *** Last line of MB03FD ***
      END


C
C**************************  VOLFIN  ***********************************
C
C      implements Finite Volume method at each time-step
C
C***********************************************************************
C
      subroutine volfin(nnode,ntria,ntetra,nface,npfa_tra,n1,nstr,nzone,
     1            flag_temp,flag_interp,flag_limiter,
     2            plist,puntdir,side_cnc,iside,neigh,neigbc,
     3            tetravert,tvert,tetra,ip4,x,y,z,xc,yc,zc,
     4            deltatadv,volur,volu,vn,swpint_el,swint_el,
     5            poros,cold_el,
     6            cnew_el,cdiff,prescfa_tra,flux,precl,precr,time)
C
      implicit none
      INCLUDE 'CATHY.H'
      integer nnode, ntria,ntetra,nface,nstr,npfa_tra,n1,nzone
      integer flag_interp,flag_limiter,ip4(4,4),flag_temp
      integer plist(2,*),side_cnc(4,*),puntdir(*)
      integer neigh(4,*),neigbc(3,*)
      integer iside(3,*),tetravert(NMAX,*)
      integer tvert(*),tetra(5,*)
      integer istrato,istr,izone,itetra
c
      real*8  tot
      real*8  poros(MAXSTR,*),x(*),y(*),z(*)
      real*8  xc(*),yc(*),zc(*)
      real*8  volur(*),volu(*),deltatadv
      real*8  vn(*),cold_el(*),cnew_el(*),cdiff(*)
      real*8  prescfa_tra(*),flux(*),precl(*)
      real*8  precr(*)
      real*8  swpint_el(*),swint_el(*)
      real*8  massnew,massold
      integer NTLAYER,j,i,iface
      real*8  time,c,a,b
      external istrato
C  flag_temp = 0  --->  Euler scheme in time and Godunov reconstruction
C  flag_temp =1   --->  Euler scheme in time and 2nd order reconstruction
C  flag_temp=2    ---> correction term added in midpoint(Euler) scheme in time
C  flag_temp=3    ---> Mid-point scheme in time, Runge scheme
C  flag_temp=4    --->  Heun scheme in time
C -----------------------------------------------------------------------
C flag_interp .eq. 1 -->  construction of the interpolant as in Durlofsky
C ------------------      scheme taking into account the 4 possible interpolant
C                        that can be constructed from the refering tetrahedron
C    flag_limiter = 0        Durloflsky limiter
C    flag_limiter = 1        min-limiter
C    flag_limiter = 2        the maximum  gradient interpolant is chosen with
C                            no limiter
C    flag_limiter =3         the average of the 4 interpolant is applied with
C                            no limiter
C flag_interp .eq.2  -->  construction of the interpolant considering the 4
C -----------------       neighbours tetrahedra
C    flag_limiter =1         extremum limiter (see paper: compressible large
C                            eddy simulation using unstructured grid:
C                            supersonic boundary layer and compression ramps,
C                            Yan, Urbin, Knight, 10th Intern. Conf. on Methods
C                            of Aerophysical Research,July 9-16 2000,
C                            Novosibirsk, Russia
C    flag_limiter =2         Limited Central Difference LCD limiter  (see paper
C                            Multidimensional Slope Limiters for MUSCL-type
C                            finite volume schemes on unstructured grids,
C                             M.E. Hubbard, J. Comp. Phys. 155, pp.54-74, 1999)
C    flag_limiter =3         no limiter is applied
C    flag_limiter=4          Barth-Jespersen limiter (see paper: The design and
C                            application of upwind schemes on unstructerd
C                            meshes, T. J. Barth, D. C. Jespersen, AIAA-89-0366)
C flag_interp.eq.3  --->  MLG scheme: the interpolant is chosen between
C ----------------        all the interpolant that can be constructed both
C                        with flag_interp.eq.1. and flag_interp.eq.2
C                        Between them, the 'proper' interpolant is limited
C                        with the LCD limiter (see above)
C flag_interp.eq.4  --->  MLS interpolant: the interpolant is chosen by the
C ----------------       least squares method
C     flag_limiter =1          extremum limiter
C     flag_limiter=2           LCD limiter
C     flag_limiter =3          no limiter
C     flag_limiter=4           Barth-Jespersen limiter
C  -------------------------------------------------------

      call init0r(ntemax,flux)
      call init0r(nfacemax,precl)
      call init0r(nfacemax,precr)
      if (flag_temp.eq.0) then
C
C      godunov reconstruction and Euler in time
C
C     WITH THIS SUBROUTINE THE VALUE OF CONCENTRATION AT THE RIGHT (precr)
C     AND LEFT (precl) SIDE OF EACH FACE IS SET
          call godunov(ntetra,nface,npfa_tra,side_cnc,
     1                 puntdir,plist,cold_el,prescfa_tra,precl,precr)
C     WITH THIS SUBROUTINE IT IS CALCULATING THE FLUX (flux) GOING OUT/IN
C     FOR EACH ELEMENT
          call durlo(ntetra,nface,volur,plist,vn,precl,precr,time,flux)
C
C     end of godunov reconstruction

C
      elseif ((flag_temp.eq.1).or.(flag_temp.eq.2)
     1       .or.(flag_temp.eq.10)) then
C
C    Durlofsky reconstruction
C    CARLOTTA NON SONO D'ACCORDO
C    flag_temp.eq.1 ==> Dirichlet BC's calculated at time t^{k+1/2} (mid-point
C                       in time)
C    flag_temp.eq.2 ==> correction term to obtain second order when applying
C                       the time-splitting technique
C    flag_temp.eq.10 ==> Euler in time
       if (flag_interp.eq.1) then
          call   tvd_durlo(nnode,ntetra,nface,npfa_tra,n1,
     1                     flag_limiter,flag_temp,neigh,
     2                     side_cnc,puntdir,plist,iside,ip4,
     3                     tetravert,tetra,
     4                     x,y,z,xc,yc,zc,cold_el,cdiff,prescfa_tra,
     5                     precl,precr)
       elseif ((flag_interp.eq.2).or.(flag_interp.eq.4)) then
          call   extr_tvd(nnode,ntetra,nface,npfa_tra,n1,
     1                     flag_limiter,flag_interp,flag_temp,neigh,
     2                     side_cnc,puntdir,plist,iside,ip4,
     3                     tetravert,tetra,
     4                     x,y,z,xc,yc,zc,cold_el,cdiff,prescfa_tra,
     5                     precl,precr)
       elseif (flag_interp.eq.3) then
          call   mlg_limiter(nnode,ntetra,nface,npfa_tra,n1,
     1                     flag_temp,neigh,
     2                     side_cnc,puntdir,plist,iside,ip4,
     3                     tetravert,tetra,
     4                     x,y,z,xc,yc,zc,cold_el,cdiff,prescfa_tra,
     5                     precl,precr)
       end if
          call durlo(ntetra,nface,volur,plist,vn,precl,precr,time,flux)
      elseif (flag_temp.eq.3) then
C
C  2nd order Runge method:
C
       if (flag_interp.eq.1) then
          call   tvd_durlo(nnode,ntetra,nface,npfa_tra,n1,
     1                     flag_limiter,flag_temp,neigh,
     2                     side_cnc,puntdir,plist,iside,ip4,
     3                     tetravert,tetra,
     4                     x,y,z,xc,yc,zc,cold_el,cdiff,prescfa_tra,
     5                     precl,precr)
       elseif ((flag_interp.eq.2).or.(flag_interp.eq.4)) then
          call extr_tvd(nnode,ntetra,nface,npfa_tra,n1,
     1                     flag_limiter,flag_interp,flag_temp,neigh,
     2                     side_cnc,puntdir,plist,iside,ip4,
     3                     tetravert,tetra,
     4                     x,y,z,xc,yc,zc,cold_el,cdiff,prescfa_tra,
     5                     precl,precr)
       elseif (flag_interp.eq.3) then
          call mlg_limiter(nnode,ntetra,nface,npfa_tra,n1,
     1                     flag_temp,neigh,
     2                     side_cnc,puntdir,plist,iside,ip4,
     3                     tetravert,tetra,
     4                     x,y,z,xc,yc,zc,cold_el,cdiff,prescfa_tra,
     5                     precl,precr)
       end if
          call durlo(ntetra,nface,volur,plist,vn,precl,precr,time,flux)

CC    THE NEW CONCENTRATION OF EACH ELEMENT IS PERFORMED BY COMPUTING
CC    A MASS BALANCE OVER IT BETWEEN THE OLD AND NEW ADVECTOVE TIME
CC    LEVEL

          do itetra=1,ntetra
            istr=istrato(itetra,ntria)
            izone=tetra(5,itetra)
            massold = cold_el(itetra)*swpint_el(itetra)
     1                *poros(istr,izone)
c            massnew = massold + 0.5d0*deltatadv*flux(itetra)
            massnew = massold + deltatadv*flux(itetra)
            cnew_el(itetra)=massnew/(swint_el(itetra)*poros(istr,izone))
         end do
       if (flag_interp.eq.1) then
          call tvd_durlo(nnode,ntetra,nface,npfa_tra,n1,
     1                     flag_limiter,flag_temp,neigh,
     2                     side_cnc,puntdir,plist,iside,ip4,
     3                     tetravert,tetra,
     4                     x,y,z,xc,yc,zc,cnew_el,cdiff,prescfa_tra,
     5                     precl,precr)
       elseif ((flag_interp.eq.2).or.(flag_interp.eq.4)) then
          call extr_tvd(nnode,ntetra,nface,npfa_tra,n1,
     1                     flag_limiter,flag_interp,flag_temp,neigh,
     2                     side_cnc,puntdir,plist,iside,ip4,
     3                     tetravert,tetra,
     4                     x,y,z,xc,yc,zc,cnew_el,cdiff,prescfa_tra,
     5                     precl,precr)
       elseif (flag_interp.eq.3) then
          call   mlg_limiter(nnode,ntetra,nface,npfa_tra,n1,
     1                     flag_temp,neigh,
     2                     side_cnc,puntdir,plist,iside,ip4,
     3                     tetravert,tetra,
     4                     x,y,z,xc,yc,zc,cnew_el,cdiff,prescfa_tra,
     5                     precl,precr)
       end if
          call durlo(ntetra,nface,volur,plist,vn,precl,precr,time,flux)

      else if (flag_temp.eq.4) then
C 2nd order Runge-Kutta method (Heun method)
       if (flag_interp.eq.1) then
          call   tvd_durlo(nnode,ntetra,nface,npfa_tra,n1,
     1                     flag_limiter,flag_temp,neigh,
     2                     side_cnc,puntdir,plist,iside,ip4,
     3                     tetravert,tetra,
     4                     x,y,z,xc,yc,zc,cold_el,cdiff,prescfa_tra,
     5                     precl,precr)
       elseif ((flag_interp.eq.2).or.(flag_interp.eq.4)) then
          call   extr_tvd(nnode,ntetra,nface,npfa_tra,n1,
     1                     flag_limiter,flag_interp,flag_temp,neigh,
     2                     side_cnc,puntdir,plist,iside,ip4,
     3                     tetravert,tetra,
     4                     x,y,z,xc,yc,zc,cold_el,cdiff,prescfa_tra,
     5                     precl,precr)
       elseif (flag_interp.eq.3) then
          call mlg_limiter(nnode,ntetra,nface,npfa_tra,n1,
     1                     flag_temp,neigh,
     2                     side_cnc,puntdir,plist,iside,ip4,
     3                     tetravert,tetra,
     4                     x,y,z,xc,yc,zc,cold_el,cdiff,prescfa_tra,
     5                     precl,precr)
       end if
          call durlo(ntetra,nface,volur,plist,vn,precl,precr,time,flux)
C CARLOTTA Finish first step Heun scheme: I am calculating c^{ka+1} read
C in a second time as input for the second step of the Heun scheme
C (which updates c^{ka+1})
          do itetra=1,ntetra
            istr=istrato(itetra,ntria)
            izone=tetra(5,itetra)
            massold = cold_el(itetra)*swpint_el(itetra)
     1                *poros(istr,izone)
            massnew = massold + deltatadv*flux(itetra)
            cnew_el(itetra)=massnew/(swint_el(itetra)*poros(istr,izone))
          end do
          tot=0.0d0
          do itetra=1,ntetra
             istr=istrato(itetra,ntria)
             izone=tetra(5,itetra)
             tot=tot+swint_el(itetra)*poros(istr,izone)*
     1       cnew_el(itetra)*volu(itetra)
          end do
c          write(*,*)'BILANCIO_PRIMO',time,tot
       if (flag_interp.eq.1) then
          call tvd_durlo(nnode,ntetra,nface,npfa_tra,n1,
     1                     flag_limiter,flag_temp,neigh,
     2                     side_cnc,puntdir,plist,iside,ip4,
     3                     tetravert,tetra,
     4                     x,y,z,xc,yc,zc,cnew_el,cdiff,prescfa_tra,
     5                     precl,precr)
       elseif ((flag_interp.eq.2).or.(flag_interp.eq.4)) then
cc CARLOTTA For second step Heun scheme
          call extr_tvd(nnode,ntetra,nface,npfa_tra,n1,
     1                     flag_limiter,flag_interp,flag_temp,neigh,
     2                     side_cnc,puntdir,plist,iside,ip4,
     3                     tetravert,tetra,
     4                     x,y,z,xc,yc,zc,cnew_el,cdiff,prescfa_tra,
     5                     precl,precr)

       elseif (flag_interp.eq.3) then
          call   mlg_limiter(nnode,ntetra,nface,npfa_tra,n1,
     1                     flag_temp,neigh,
     2                     side_cnc,puntdir,plist,iside,ip4,
     3                     tetravert,tetra,
     4                     x,y,z,xc,yc,zc,cnew_el,cdiff,prescfa_tra,
     5                     precl,precr)
       end if
          call durlo(ntetra,nface,volur,plist,vn,precl,precr,time,flux)

cc CARLOTTA Second step Heun scheme

        do itetra=1,ntetra
           istr=istrato(itetra,ntria)
           izone=tetra(5,itetra)
           massold = cnew_el(itetra)*swint_el(itetra)*poros(istr,izone)
           massnew = massold + deltatadv*flux(itetra)
           massnew= 0.5d0*(massnew + cold_el(itetra)*swpint_el(itetra)*
     1              poros(istr,izone))
           cnew_el(itetra)=massnew/(swint_el(itetra)*poros(istr,izone))
        end do
          tot=0.0d0
          do itetra=1,ntetra
             istr=istrato(itetra,ntria)
             izone=tetra(5,itetra)
             tot=tot+swint_el(itetra)*poros(istr,izone)*
     1       cnew_el(itetra)*volu(itetra)
          end do
c          write(*,*)'BILANCIO_SECONDO',time,tot
      end if
C
C     application of predictor on time integration
C
      if (flag_temp.ne.4) then
        do itetra=1,ntetra
           istr=istrato(itetra,ntria)
           izone=tetra(5,itetra)
           massold = cold_el(itetra)*swpint_el(itetra)*poros(istr,izone)
           massnew = massold + deltatadv*flux(itetra)
           cnew_el(itetra)=massnew/(swint_el(itetra)*poros(istr,izone))
        end do
       end if

      return

      end


      SUBROUTINE W3FC08(FFID, FFJD, FU, FV, FGU, FGV)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:  W3FC08        U-V COMPS FROM EARTH TO NORTH HEM GRID
C   PRGMMR: CHASE            ORG: NMC421      DATE:88-10-26
C
C ABSTRACT: GIVEN THE EARTH-ORIENTED WIND COMPONENTS ON A NORTHERN
C   HEMISPHERE POLAR STEREOGRAPHIC GRID POINT, COMPUTE THE GRID-
C   ORIENTED COMPONENTS AT THAT POINT.  INPUT WIND COMPONENTS AT THE
C   NORTH POLE POINT ARE ASSUMED TO CONFORM TO
C   THE 'WMO' STANDARDS FOR REPORTING WINDS AT THE NORTH POLE, WITH
C   THE OUTPUT COMPONENTS COMPUTED RELATIVE TO THE X-Y AXES ON THE
C   GRID.  (SEE OFFICE NOTE 241 FOR WMO DEFINITION.)
C
C PROGRAM HISTORY LOG:
C   81-12-30  STACKPOLE, J.
C   88-10-18  CHASE, P.   LET OUTPUT VARIABLES OVERLAY INPUT
C   91-03-06  R.E.JONES   CHANGE TO CRAY CFT77 FORTRAN
C
C USAGE:    CALL W3FC08 (FFID, FFJD, FU, FV, FGU, FGV)
C
C   INPUT ARGUMENT LIST:
C     FFID     - REAL   I-DISPLACEMENT FROM POINT TO NORTH POLE IN
C                GRID UNITS
C     FFJD     - REAL   J-DISPLACEMENT FROM POINT TO NORTH POLE IN
C                GRID UNITS
C     FU       - REAL   EARTH-ORIENTED U-COMPONENT, POSITIVE FROM WEST
C     FV       - REAL   EARTH-ORIENTED V-COMPONENT, POSITIVE FROM EAST
C
C   OUTPUT ARGUMENT LIST:
C     FGU      - REAL   GRID-ORIENTED U-COMPONENT.  MAY REFERENCE
C                SAME LOCATION AS FU.
C     FGV      - REAL   GRID-ORIENTED V-COMPONENT.  MAY REFERENCE
C                SAME LOCATION AS FV.
C
C   INPUT FILES:   NONE
C
C   OUTPUT FILES:  NONE
C
C   SUBPROGRAMS CALLED:
C     LIBRARY:
C       COMMON   - SQRT
C
C REMARKS:  FFID AND FFJD MAY BE CALCULATED AS FOLLOWS.....
C     FFID = REAL(IP - I)
C     FFJD = REAL(JP - J)
C   WHERE (IP, JP) ARE THE GRID COORDINATES OF THE NORTH POLE AND
C   (I,J) ARE THE GRID COORDINATES OF THE POINT.
C
C ATTRIBUTES:
C   LANGUAGE: CRAY CFT77 FORTRAN
C   MACHINE:  CRAY C916-128, CRAY Y-MP8/864, CRAY Y-MP EL2/256
C
C$$$
C
      SAVE
C
      DATA  COS280/  0.1736482 /
      DATA  SIN280/ -0.9848078 /
C
C     COS280 AND SIN280 ARE FOR WIND AT POLE
C     (USED FOR CO-ORDINATE ROTATION TO GRID ORIENTATION)
C
      DFP = SQRT(FFID * FFID + FFJD * FFJD)
      IF (DFP .EQ. 0.) THEN
        XFGU = -(FU * COS280 + FV * SIN280)
        FGV  = -(FV * COS280 - FU * SIN280)
      ELSE
        XFGU = (FU * FFJD + FV * FFID) / DFP
        FGV  = (FV * FFJD - FU * FFID) / DFP
      ENDIF
      FGU = XFGU
      RETURN
      END


c=======================================================================
c
c     subroutine CHTCOVM
c
c     covariance matrix with poor historic
c    (computes the covariances independantly with the available
c     historic and correct the matrix with SDLS)
c
c-----------------------------------------------------------------------
      SUBROUTINE chtcovm ( ndate, n, nintro, dasset, age, unborn,
     &                     hole, iwork, dwork, mean, cov, info )
c-----------------------------------------------------------------------
c
c     INPUT
c            ndate  : lagest estimation period                   integer
c            n      : nb of assets                               integer
c            nintro : nb of days after the birth of an asset
c                     before introducing it in the covariance
c                     matrix                                     integer
c            dasset : values (returns, spreads...) of the assets
c                     during the estimation period
c                     (with value = hole if unknown)
c                     vectorized matrix (ndate*nasset)            double
c            age    : age of the assets (number of dates since
c                     which their quotations are known in dasset)
c                     0<=age(i)<=ndate
c                     vector(nasset)                             integer
c            unborn : stand for unborn quotations                 double
c            hole   : stands for unknown value                    double
c
c     WORKSPACE
c            iwork  : 14*n + 3                                   integer
c            dwork  : n*(8*n + 40) + 1                            double
c
c     OUTPUT
c            mean   : mean of the assets (n)                      double
c            cov    : covariance matrix (n*n)                     double
c            info   : diagnostic argument                        integer
c
c     CALL
c        CHTMCM  : mean of assets with a poor historic (with unknown values)
c        SDLS    : Semi-Definite Least-Square optimization
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     i/o arguments
      INTEGER ndate, n, nintro, info, age(*)
      DOUBLE PRECISION dasset(ndate,*), cov(n,*), mean(*),
     &                 unborn, hole
c
c     workspaces
      INTEGER iwork(*)
      DOUBLE PRECISION dwork(*)
c
c     local variables
      INTEGER i, j, k, nestim, ind1st, pisdls, pdsdls, pdempcov, pdaict,
     &        pdbct
      DOUBLE PRECISION mcte, alpha, epsbfg, som
      PARAMETER ( epsbfg = 1.E-5 )
c
c-----------------------------------------------------------------------
c
c     initializations
      info = 0
c
c     pointers for integer work space : iwork
c     ---------------------------------------
c     pisdls : pointer for SDLS iwork ( 14*n + 3 )
      pisdls = 1
c
c     Total size of iwork: 14*n + 3
c
c     pointers for double precision work space : dwork
c     ------------------------------------------------
      pdsdls = 1
c     pdsdls : pointer for SDLS dwork n*(6*n + 40)
c
      pdempcov = pdsdls + ( n*(6*n + 40) )
c     pdempcov : pointer for covariance matrix ( n*n )
c
      pdaict = pdempcov + ( n*n )
c     pdaict : pointer for mct Ai constraint matrices (n*n)
c
      pdbct = pdaict + ( n*n )
c     pdbct : pointer for constraints ( 1 )
c
c     Total size of dwork = ( n*(6*n + 40))
c                         + n*n
c                         + n*n
c                         + 1
c                         = ( n*(8*n + 40)) + 1
c
c-----------------------------------------------------------------------
c
c     computing means of rents
c     by construction, unknown values of this historic are
c     unborn (historic was
c        1) interpolated to fill holes
c        2) built with BLDHIST.F (to omit dead values)
c        before calling CHTCOVM)
      CALL chtmcm ( ndate, n, dasset, unborn, age, mean, info )
      IF (info .LT. 0) RETURN
c
c     computing empiric covariance matrix
      do i = 1,n
         do j=1,i
c
c           for each couple of assets (i,j) s.t. i<=j
c           compute the estimation period = min(age(i),age(j))
            if (age(i) .le. age(j)) then
               nestim = age(i)
            else
               nestim = age(j)
            end if
c           if asset i or j has a too short historic (age<nintro)
c           then empcov(i,j) = unknown = hole
            if (nestim .lt. nintro) then
               dwork(pdempcov+(j-1)*n + i - 1) = hole
               info = 1
            else
c
c              if nestim too big, nestim:=ndate
               if (nestim .gt. ndate) nestim = ndate
c
c              compute the 1st index of the estimation period
               ind1st = ndate - nestim + 1
c              compute the empirical covariance bewteen those 2 assets
c              with nestim historical values
               som = 0
               do k = ind1st,ndate
                  som = som + (dasset(k,i)-mean(i))
     &                       *(dasset(k,j)-mean(j))
               end do
                dwork(pdempcov+(j-1)*n + i - 1) = som/(nestim-1)
            end if
c
            if (i .ne. j) then
c              empcov is symmetric : no use to make this computation
c              twice
               dwork(pdempcov+(i-1)*n + j - 1)
     &              = dwork(pdempcov+(j-1)*n + i - 1)
            end if
c
         end do
      end do
c
c     covariance matrix correction by SDLS without constraints
c     min. eigenvalue = 1.e-10
      mcte  = 0.
      alpha = 1.e-10
      CALL sdls ( n, dwork(pdempcov), mcte, dwork(pdaict), dwork(pdbct),
     &            epsbfg, alpha,
     &            iwork(pisdls),dwork(pdsdls),
     &            cov, info)
c
      RETURN
      END