real f_to_c_offset = 32.0
real f_to_c_factor = 0.555555555

function fahrenheit_to_celsius_bad(temp_f) result(temp_c)
   implicit none
   real temp_f
   real temp_c
   temp_c = (temp_f - f_to_c_offset) * f_to_c_factor
end function fahrenheit_to_celsius_bad

temp_c = fahrenheit_to_celsius_bad(100.0)
write(*,*) temp_c


*DECK QAG
      SUBROUTINE QAG (F, A, B, EPSABS, EPSREL, KEY, RESULT, ABSERR,
     +   NEVAL, IER, LIMIT, LENW, LAST, IWORK, WORK)
C***BEGIN PROLOGUE  QAG
C***PURPOSE  The routine calculates an approximation result to a given
C            definite integral I = integral of F over (A,B),
C            hopefully satisfying following claim for accuracy
C            ABS(I-RESULT)LE.MAX(EPSABS,EPSREL*ABS(I)).
C***LIBRARY   SLATEC (QUADPACK)
C***CATEGORY  H2A1A1
C***TYPE      SINGLE PRECISION (QAG-S, DQAG-D)
C***KEYWORDS  AUTOMATIC INTEGRATOR, GAUSS-KRONROD RULES,
C             GENERAL-PURPOSE, GLOBALLY ADAPTIVE, INTEGRAND EXAMINATOR,
C             QUADPACK, QUADRATURE
C***AUTHOR  Piessens, Robert
C             Applied Mathematics and Programming Division
C             K. U. Leuven
C           de Doncker, Elise
C             Applied Mathematics and Programming Division
C             K. U. Leuven
C***DESCRIPTION
C
C        Computation of a definite integral
C        Standard fortran subroutine
C        Real version
C
C            F      - Real
C                     Function subprogram defining the integrand
C                     Function F(X). The actual name for F needs to be
C                     Declared E X T E R N A L in the driver program.
C
C            A      - Real
C                     Lower limit of integration
C
C            B      - Real
C                     Upper limit of integration
C
C            EPSABS - Real
C                     Absolute accuracy requested
C            EPSREL - Real
C                     Relative accuracy requested
C                     If  EPSABS.LE.0
C                     And EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28),
C                     The routine will end with IER = 6.
C
C            KEY    - Integer
C                     Key for choice of local integration rule
C                     A GAUSS-KRONROD PAIR is used with
C                       7 - 15 POINTS If KEY.LT.2,
C                      10 - 21 POINTS If KEY = 2,
C                      15 - 31 POINTS If KEY = 3,
C                      20 - 41 POINTS If KEY = 4,
C                      25 - 51 POINTS If KEY = 5,
C                      30 - 61 POINTS If KEY.GT.5.
C
C         ON RETURN
C            RESULT - Real
C                     Approximation to the integral
C
C            ABSERR - Real
C                     Estimate of the modulus of the absolute error,
C                     Which should EQUAL or EXCEED ABS(I-RESULT)
C
C            NEVAL  - Integer
C                     Number of integrand evaluations
C
C            IER    - Integer
C                     IER = 0 Normal and reliable termination of the
C                             routine. It is assumed that the requested
C                             accuracy has been achieved.
C                     IER.GT.0 Abnormal termination of the routine
C                             The estimates for RESULT and ERROR are
C                             Less reliable. It is assumed that the
C                             requested accuracy has not been achieved.
C                      ERROR MESSAGES
C                     IER = 1 Maximum number of subdivisions allowed
C                             has been achieved. One can allow more
C                             subdivisions by increasing the value of
C                             LIMIT (and taking the according dimension
C                             adjustments into account). HOWEVER, If
C                             this yield no improvement it is advised
C                             to analyze the integrand in order to
C                             determine the integration difficulties.
C                             If the position of a local difficulty can
C                             be determined (I.E. SINGULARITY,
C                             DISCONTINUITY WITHIN THE INTERVAL) One
C                             will probably gain from splitting up the
C                             interval at this point and calling the
C                             INTEGRATOR on the SUBRANGES. If possible,
C                             AN APPROPRIATE SPECIAL-PURPOSE INTEGRATOR
C                             should be used which is designed for
C                             handling the type of difficulty involved.
C                         = 2 The occurrence of roundoff error is
C                             detected, which prevents the requested
C                             tolerance from being achieved.
C                         = 3 Extremely bad integrand behaviour occurs
C                             at some points of the integration
C                             interval.
C                         = 6 The input is invalid, because
C                             (EPSABS.LE.0 AND
C                              EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28))
C                             OR LIMIT.LT.1 OR LENW.LT.LIMIT*4.
C                             RESULT, ABSERR, NEVAL, LAST are set
C                             to zero.
C                             EXCEPT when LENW is invalid, IWORK(1),
C                             WORK(LIMIT*2+1) and WORK(LIMIT*3+1) are
C                             set to zero, WORK(1) is set to A and
C                             WORK(LIMIT+1) to B.
C
C         DIMENSIONING PARAMETERS
C            LIMIT - Integer
C                    Dimensioning parameter for IWORK
C                    Limit determines the maximum number of subintervals
C                    in the partition of the given integration interval
C                    (A,B), LIMIT.GE.1.
C                    If LIMIT.LT.1, the routine will end with IER = 6.
C
C            LENW  - Integer
C                    Dimensioning parameter for work
C                    LENW must be at least LIMIT*4.
C                    IF LENW.LT.LIMIT*4, the routine will end with
C                    IER = 6.
C
C            LAST  - Integer
C                    On return, LAST equals the number of subintervals
C                    produced in the subdivision process, which
C                    determines the number of significant elements
C                    actually in the WORK ARRAYS.
C
C         WORK ARRAYS
C            IWORK - Integer
C                    Vector of dimension at least limit, the first K
C                    elements of which contain pointers to the error
C                    estimates over the subintervals, such that
C                    WORK(LIMIT*3+IWORK(1)),... , WORK(LIMIT*3+IWORK(K))
C                    form a decreasing sequence with K = LAST If
C                    LAST.LE.(LIMIT/2+2), and K = LIMIT+1-LAST otherwise
C
C            WORK  - Real
C                    Vector of dimension at least LENW
C                    on return
C                    WORK(1), ..., WORK(LAST) contain the left end
C                    points of the subintervals in the partition of
C                     (A,B),
C                    WORK(LIMIT+1), ..., WORK(LIMIT+LAST) contain the
C                     right end points,
C                    WORK(LIMIT*2+1), ..., WORK(LIMIT*2+LAST) contain
C                     the integral approximations over the subintervals,
C                    WORK(LIMIT*3+1), ..., WORK(LIMIT*3+LAST) contain
C                     the error estimates.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  QAGE, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   800101  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C***END PROLOGUE  QAG
      REAL A,ABSERR,B,EPSABS,EPSREL,F,RESULT,WORK
      INTEGER IER,IWORK,KEY,LENW,LIMIT,LVL,L1,L2,L3,NEVAL
C
      DIMENSION IWORK(*),WORK(*)
C
      EXTERNAL F
C***FIRST EXECUTABLE STATEMENT  QAG
      IER = 6
      NEVAL = 0
      LAST = 0
      RESULT = 0.0E+00
      ABSERR = 0.0E+00
      IF (LIMIT.GE.1 .AND. LENW.GE.LIMIT*4) THEN
C
C        PREPARE CALL FOR QAGE.
C
         L1 = LIMIT+1
         L2 = LIMIT+L1
         L3 = LIMIT+L2
C
         CALL QAGE(F,A,B,EPSABS,EPSREL,KEY,LIMIT,RESULT,ABSERR,NEVAL,
     1     IER,WORK(1),WORK(L1),WORK(L2),WORK(L3),IWORK,LAST)
C
C        CALL ERROR HANDLER IF NECESSARY.
C
         LVL = 0
      ENDIF
C
      IF (IER.EQ.6) LVL = 1
      IF (IER .NE. 0) CALL XERMSG ('SLATEC', 'QAG',
     +   'ABNORMAL RETURN', IER, LVL)
      RETURN
      END


	SUBROUTINE UMAT(STRESS,STATEV,DDSDDE,SSE,SPD,SCD,RPL, &
        DDSDDT,DRPLDE,DRPLDT,STRAN,DSTRAN,TIME,DTIME,TEMP, &
	  DTEMP,PREDEF,DPRED,CMNAME,NDI,NSHR,NTENS,NSTATV,PROPS,&
	  NPROPS,COORDS,DROT,PNEWDT,CELENT,DFGRD0,DFGRD1,NOEL,NPT,&
	  LAYER,KSPT,JSTEP,KINC)
      INCLUDE 'ABA_PARAM.INC'
      implicit none

      CHARACTER*80 CMNAME
      INTEGER, INTENT(IN):: NTENS,NSTATV,NPROPS
      real, intent(inout) :: STRESS(NTENS),STATEV(NSTATV), DDSDDE(NTENS,NTENS), &
           DDSDDT(NTENS),DRPLDE(NTENS),STRAN(NTENS),DSTRAN(NTENS), &
           TIME(2),PREDEF(1),DPRED(1),PROPS(NPROPS),COORDS(3), &
           DROT(3,3),DFGRD0(3,3),DFGRD1(3,3),JSTEP(4)
      real, intent(in) :: SSE,SPD,SCD,RPL,DRPLDT,DTEMP,TEMP,DTIME,NDI,NSHR, &
      PNEWDT,CELENT,NOEL,NPT, LAYER,KSPT,KINC

	real, parameter :: ONE=1.0 , TWO=2.0
      real :: I,J,E,ANU,ALAMBDA,AMU
		E= props(1)
		ANU= props(2)
		ALAMBDA= E*ANU/(ONE+ANU)/(ONE - TWO*ANU)
		AMU=E/(ONE+ANU)/2
		DO I=1,NTENS
			DO J=1,NTENS
			DDSDDE(I,J)=0.0
			END DO
		END DO
		DDSDDE(1,1)=(ALAMBDA+TWO*AMU)
		DDSDDE(2,2)=(ALAMBDA+TWO*AMU)
		DDSDDE(3,3)=(ALAMBDA+TWO*AMU)
		DDSDDE(4,4)= AMU
		DDSDDE(5,5)= AMU
		DDSDDE(6,6)= AMU
		DDSDDE(1,2)= ALAMBDA
		DDSDDE(1,3)= ALAMBDA
		DDSDDE(2,3)= ALAMBDA
		DDSDDE(3,1)= ALAMBDA
		DDSDDE(3,1)= ALAMBDA
		DDSDDE(3,2)= ALAMBDA
			DO I=1,NTENS
				DO J=1,NTENS
				STRESS(I)= STRESS(I)+DDSDDE(I,J)*DSTRAN(J)
				END DO
			END DO

      RETURN
      END SUBROUTINE UMAT


c=======================================================================
c
c     subroutine CLUSTER
c
c     Cluster Analysis
c
c     Method: mixture approach based on multivariate Gaussian mixture
c             model(s). The parameters are obtained from M.L. estimates
c             by the EM algorithm.
c
c-----------------------------------------------------------------------
      SUBROUTINE cluster ( n, d, k, x, iwork, dwork,
     &                     pk, nk, muk, covk, label, proba, f, info )
c-----------------------------------------------------------------------
c
c     INPUT
c       n        : number of points (n>1)                        integer
c       d        : dimension (d>0)                               integer
c       k        : number of class (k>0)                         integer
c       x        : data (n*d)                                     double
c
c     WORKSPACE
c       iwork    : d                                             integer
c       dwork    : d*(3*d + k + 9) + n                            double
c
c     OUTPUT
c       pk       : proportion of each group (k)                   double
c       nk       : number of each group (k)                      integer
c       muk      : mean of each group (d*k)                       double
c       covk     : cov. matrix of each group (d)*(d*k)            double
c       label    : partition labels (n*k)                        integer
c       proba    : conditionale probability (n*k)                 double
c       f        : probability (n*k)                              double
c       info     : diagnostic argument                           integer
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER n, d, k, nk(*), label(n,*), info
      DOUBLE PRECISION x(n,*), pk(*), proba(n,*), muk(d,*), covk(d,*),
     &                 f(n,*)
c
c     workspaces
      INTEGER iwork(*)
      DOUBLE PRECISION dwork(*)
c
c     local variables
      INTEGER i, j, l, itermax, piw, pdw, pdmuk, pdxi, ri
      DOUBLE PRECISION like, liketmp, variance, ZERO
      PARAMETER (ZERO = 0.0)
      REAL unif
c
c     external subroutines
      EXTERNAL em, YM
c
c-----------------------------------------------------------------------
c
c     initializations
      info = 0
      itermax = 10
c
c     pointers for integer work space  : iwork
c     ----------------------------------------
      piw = 1
c     piw : pointer for ESTEP, so ( d ) more
c
c     Total size of dwork array = ( d )
c
c     pointers for double precision work space  : dwork
c     -------------------------------------------------
      pdw = 1
c     pdw : pointer for ESTEP, so ( d*(3*d + 9) ) more
      pdmuk = pdw + d*(3*d+9)
c     pdmuk : pointer for muk, so ( d*k ) more
      pdxi  = pdmuk + ( d*k )
c     pdxi  : pointer for x(i), so ( n ) more
c
c     Total size of dwork array = d*(3*d + 9)
c                               + d*k
c                               + n
c                               = d*(3*d + k + 9) + n
c
c------------------------------------------------------------------------
c      open(unit=1,file='CLUSTER.txt',status='unknown')
c      write(1,*) "Begin CLUSTER"
c
c     parameter initialization
c     ------------------------
c     mean initialization to x(1,k) and proportion to 1/K
c
c     matrix identity by block (d)*(d*k)
c
c            | 1 0 ... 0   ...   1 0 ... 0 |
c            | 0 1 ... 0   ...   0 1 ... 0 |
c     covk = | . .     .   ...   . .     . |
c            | . .     .   ...   . .     . |
c            | 0 0 ... 1   ...   0 0 ... 1 |
c
      DO l = 1,k
        pk(l) = 1./float(k)
        DO i = 1,d
            CALL YCMV ( n, d, x, i, dwork(pdxi), info )
            CALL VARIAN ( n, dwork(pdxi), variance, info )
            covk(i, d*(l-1) + i) = variance
            muk(i,l) = x(l,i)
c            write(1,*) "mu initial(",i,",",l,")=", muk(i,l)
        ENDDO
      ENDDO
c
c     initialisation by EM algorithm
c      write(1,*) "Begin EM"

      CALL em ( itermax, n, d, k, x, iwork(piw), dwork(pdw),
     &          pk, nk, muk, covk, label, proba, f, like, info )
      CALL YM ( d, k, muk, dwork(pdmuk))
c
c     initialization loop
      DO j = 1,100
c
c       initialisation: pk, covk, muk
        CALL IMX ( d, d*k, covk, ZERO )
        DO l = 1,k
            pk(l) = 1./float(k)
#ifdef INTELFOR
        CALL RANDOM_NUMBER(HARVEST = unif)
#else
        unif = rand()
#endif
            ri = int(unif*n)+1
            DO i = 1,d
                CALL YCMV ( n, d, x, i, dwork(pdxi), info )
                CALL VARIAN ( n, dwork(pdxi), variance, info )
                covk(i, d*(l-1) + i) = variance
                muk(i,l) = x(ri,i)
c                write(1,*) "mu Random=", muk(i,l)
            ENDDO
        ENDDO
c
c       EM algorithm
        CALL em ( itermax, n, d, k, x, iwork(piw), dwork(pdw),
     &            pk, nk, muk, covk, label, proba, f, liketmp, info )
c
        IF (liketmp .GT. like) THEN
            like = liketmp
            CALL YM ( d, k, muk, dwork(pdmuk))
c            write(1,*) "tests OK"
        ENDIF

      ENDDO

      CALL YM ( d, k, dwork(pdmuk), muk)
c
c     initialisation: pk (proportion), covk (cov. matrix)
      CALL IMX ( d, d*k, covk, zero )
      DO l = 1,k
        DO i = 1,d
            covk(i, d*(l-1) + i) = 1.0
        ENDDO
        pk(l) = 1./float(k)
      ENDDO
      itermax = 50
      CALL em ( itermax, n, d, k, x, iwork(piw), dwork(pdw),
     &          pk, nk, muk, covk, label, proba, f, like, info )
c
      RETURN
      END


   MODULE TESTER
   implicit none
   integer, parameter:: in=5,im=2 !! 'in' is the number of species in each patch, 'im' is the number of patches in the metacommunity
   integer, parameter:: imn=in*(im+1), npar=imn*(in+3) !! 'imn' - state space dimension, 'npar' - total parameters
   real(kind=4):: par(npar)

    CONTAINS

      SUBROUTINE DERIVS(NEQ,T,Y,YDOT)
        IMPLICIT NONE
        INTEGER NEQ
        REAL T, Y, YDOT
        DIMENSION Y(NEQ), YDOT(NEQ)
        integer(kind=4)::i,j,k,iti,iti1,itj,itj1,kc,itc,iflag,idix
        real(kind=4):: cptsum,cdsum
        real(kind=4):: ar(im,in),akc(im,in),acpt(im,in,in),ad(im,in) !! parameters

        !*************************
        kc=0; do i=1,im; do j=1,in         !!
                kc=kc+1; ar(i,j)=par(kc) !!
              enddo; enddo               !! maximal growth rates

              do i=1,im; do j=1,in         !!
                kc=kc+1; akc(i,j)=par(kc)!!
              enddo; enddo               !! carrying capacities

              acpt=0.0                      !! competition initialization
              do i=1,im; do j=1,in; do k=1,in   !!
                kc=kc+1; acpt(i,j,k)=par(kc) !!
                if(j==k) acpt(i,j,k)=0.0    !! competition terms
              enddo; enddo; enddo            !!

              do i=1,im; do j=1,in             !!
                kc=kc+1; ad(i,j)=par(kc)     !!
              enddo; enddo                   !! dispersal terms
        !*************************
        kc=0

        do iti=1,im
         do itj=1,in

          kc=kc+1

          iflag=mod(kc,in); if(iflag==0) iflag=in; cptsum=0.0           !!
           do itj1=1,in                                                 !! competition
            if(itj1/=iflag) then                                       !! terms
           ! print*,kc,itj1+(iti-1)*n                                  !!
            cptsum=cptsum+acpt(iti,itj,itj1)*Y(itj1+(iti-1)*in)         !!
            endif
           enddo                                                       !!

           cdsum=0.0                                                  !!
           do iti1=1,im                                                 !! dispersal
            if(iti1/=iti) then                                         !! terms
           !  print*,iti1,iflag,kc,(iti1-1)*n+iflag                    !!
             cdsum=cdsum+ad(iti1,iflag)*Y((iti1-1)*in+iflag)            !!
            endif                                                      !!
           enddo

          YDOT(kc)=ar(iti,itj)*Y(kc)*(1.0-(Y(kc)+cptsum)/akc(iti,itj))+(-ad(iti,itj)*Y(kc)+cdsum/float(im-1))

        enddo
       enddo
       !pause

      RETURN
      END SUBROUTINE DERIVS

    END MODULE TESTER

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

    PROGRAM DEMOWANG

      USE TESTER
      USE random
!     Type declarations:
      IMPLICIT NONE
      INTEGER, PARAMETER :: mlyap=0, NEQ=(mlyap+1)*imn
      real  :: h, T, TOUT, xrho1, xrho2, xvar1, xvar2, kppa
      integer:: IOUT, i, j, ntrans, niter
      real,allocatable:: Y(:), YDER(:), noi_spec(:)

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! variables for the random number generator
      INTEGER, ALLOCATABLE  :: ix(:), seed(:)
      REAL, ALLOCATABLE     :: xep(:,:), xptch(:), xmeanep(:,:), xmeanptch(:), covep(:,:), covptch(:), chol_fep(:,:), &
                               chol_fptch(:), xseed(:), xcov(:,:), xtemp(:), xmeantemp(:), xcovtemp(:), xchol(:)
      INTEGER               :: nep, nptch, ndf, n_binom, k, kep, kptch, ier, pos1, pos2, which, iindx
      REAL                  :: average, stdvn, shape, a, b, mu, p, pop_mean, pop_sd,   &
                               one = 1.0, zero = 0.0, sk, two = 2.0, pcntile(9), &
                               middle, xmax, xmin, xtseed
      LOGICAL               :: first
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!     Set the random number seed.

CALL RANDOM_SEED(size=k)
ALLOCATE (seed(k),xseed(k))
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! FIXING THE SEED
do i=1,k; call cpu_time(xtseed); xseed(i)=xtseed; enddo
!call random_number(xseed)
seed=int(5000000*xseed)
CALL RANDOM_SEED(put=seed)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

xrho2=-0.4  !!print*, "Between patch correlation";
xrho1=-0.05 !!print*, "Between species correlation";
xvar1=0.04  !! species specific variance
xvar2=0.04  !! patch specific variance
kppa=8.0
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! allocation for the random number for species specific environmental response
      kep=in
      nep = kep*(kep+1)/2
       ALLOCATE( xep(im,kep), xmeanep(im,kep), covep(im,nep), chol_fep(im,nep), xtemp(kep), xmeantemp(kep), &
                 xcovtemp(nep), xchol(nep) )
!!!!!! MEAN VECTOR
      xmeanep=0.0; xmeantemp=0.0
! !
!!!!!! COVARIANCE MATRIX FOR SPECIES SPECIFIC ENVIRONMENTAL RESPONSE
      DO j=1,im
         pos2 = 0
         DO i = 1, kep
          pos1 = pos2 + 1
          pos2 = pos2 + i
          covep(j,pos1:pos2)=xrho1*xvar1; covep(j,pos2)=xvar1
         END DO
      ENDDO
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! allocation for the random number for patch specific environmental response
      kptch=im
      nptch = kptch*(kptch+1)/2
      ALLOCATE ( xptch(kptch), xmeanptch(kptch), covptch(nptch), chol_fptch(nptch) )
!!!!!! MEAN VECTOR FOR PATCHES

      xmeanptch=0.0
! !
!!!!!! COVARIANCE MATRIX FOR BETWEEN PATCH ENVIRONMENTAL RESPONSE
      pos2 = 0
      DO i = 1, kptch
        pos1 = pos2 + 1
        pos2 = pos2 + i
        covptch(pos1:pos2)=xrho2*xvar2; covptch(pos2)=xvar2
      END DO
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

  ntrans=500000; niter=10000; allocate(Y(NEQ),YDER(NEQ),noi_spec(imn)); par=0.0

!     Set  the problem parameters:
      call random_number(par(1:imn)); par(1:imn)=0.5+par(1:imn)*1.0  !! M*N MAXIMAL GROWTH RATES
      call random_number(par(imn+1:2*imn)); par(imn+1:2*imn)=0.5+par(imn+1:2*imn)*1.0  !! M*N CARRYING CAPACITIES
      call random_number(par(2*imn+1:2*imn+in*in*im)); par(2*imn+1:2*imn+in*in*im)=0.25+par(2*imn+1:2*imn+in*in*im)*0.50 !! M*N*N COMPETITION COEFFICIENTS FOR M PATCHES
      call random_number(par(2*imn+in*in*im+1:2*imn+in*in*im+imn))                                     !! DISPERSAL RATES
      par(2*imn+in*in*im+1:2*imn+in*in*im+imn)=0.050+par(2*imn+in*in*im+1:2*imn+in*in*im+imn)*0.10 !! WITHOUT SWITCHING OFF THE VALUES
      par(2*imn+in*in*im+1:2*imn+in*in*im+imn:2)=0.0                    !! EVERY ALTERNATE TERM SWITCHED OFF GIVING HALF GENERALISTS (SPECIALISTS) IN EACH PATCH
do i=1,npar; print*,par(i); enddo
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!     Set the initial conditions:
      call random_number(Y); YDER=0.0
!     Output points:
      T = 0.0
      h=0.01

!     Perform the integration:
       DO IOUT = 1, ntrans
!        print*,Y; pause
         call DERIVS(NEQ,T,Y,YDER)
          Y=Y+h*YDER; T=T+h
       ENDDO
       do i=1,imn; print*, Y(i); enddo
      first = .true.
      DO IOUT = 1, niter
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! between species random number patch
        do i=1,im; xtemp=0.0
          !xmeantemp = xmeanep(i,:); xcovtemp = covep(i,:); xchol = chol_fep(i,:)!; print*,xmeantemp; pause; print*,xcovtemp; pause; print*,xchol; pause
          !CALL random_mvnorm(kep, xmeantemp, xcovtemp, xchol, first, xtemp, ier)
          CALL random_mvnorm(kep, xmeanep(i,:), covep(i,:), chol_fep(i,:), first, xep(i,:), ier)
           IF (ier .NE. 0) THEN
            WRITE(*, *) '** Covariance matrix1 is not +ve definite **'
            PAUSE; !EXIT replaced since the do loop was removed
           END IF
          !xep(i,:)=xtemp
        enddo
        !print*,IOUT,xep; pause
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! between patch random number
       ! print*, xmeanptch; pause; print*,covptch; pause; print*,chol_fptch; pause
        CALL random_mvnorm(kptch, xmeanptch, covptch, chol_fptch, first, xptch, ier)
        IF (ier .NE. 0) THEN
          WRITE(*, *) '** Covariance matrix2 is not +ve definite **'
          PAUSE; !EXIT replaced since the do loop was removed
        END IF
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

        do i=1,im
         pos1=(i-1)*in+1; pos2=i*in
         noi_spec(pos1:pos2)=xep(i,:)
        enddo
!!        noi_spec=abs(noi_spec); xptch=abs(xptch)   !!! DO WE NEED THIS STEP?

        call DERIVS(NEQ,T,Y,YDER)

        Y=Y+h*YDER+sqrt(h)*noi_spec !! between species noise added

        do i=1,im
         pos1=(i-1)*in+1; pos2=i*in
         Y(pos1:pos2)=Y(pos1:pos2)+Y(pos1:pos2)*sqrt(h)*xptch(i) !! between patch noise added
         Y(pos1:pos2)=Y(pos1:pos2)+Y(pos1:pos2)*h*kppa*xptch(i)*noi_spec(pos1:pos2) !! multiplicative response added
        enddo
         T=T+h
        write(11,24) T,Y(1:4)
        !write(12,24) T, noi_spec,xptch
        write(12,24) T,Y(6:10)
        write(13,24) T,Y(11:15)
        write(14,24) T,Y(16:20)

        first = .false.
      END DO ! IOUT
      !first = .false.

!!! OUTPUT FILE FORMAT
      24  Format(40F20.10)

END PROGRAM DEMOWANG

!!!! CODE CURRENTLY CRASHES DUE TO IMPROPER RESTRICTIONS ON POPULATION VALUES


program plm_test

  use healpix_types
  use alm_tools, only: plm_gen
  use pix_tools
  use, intrinsic :: iso_c_binding
  use fourier, only: p_lm_gen, direct_fourier
  use map_coef, only: a_lm_gasdev

  implicit none
  double precision, dimension(:, :), allocatable :: polynom
  integer :: legendre_num = 4
  integer :: err_polynom
  double precision :: theta
  integer :: pix_num = 8

  complex, dimension(0:4) :: a_lms

  include 'fftw3.f03'

  integer(I4B) :: nside, lmax, mmax, n_plm, npix
  real(DP), dimension(:,:), allocatable :: plm

  nside=256
  lmax=512
  mmax=lmax
  npix=nside2npix(nside)

  n_plm=nside*(mmax+1)*(2*lmax-mmax+2)
  allocate(plm(0:n_plm-1,1:3))

  call plm_gen(nside, lmax, mmax, plm)

  allocate(polynom(0:legendre_num, 0:legendre_num), stat=err_polynom)
  if (err_polynom /= 0) print *, "polynom: Allocation request denied"

  theta = 2.d0 * PI * (2 - 1) / pix_num

  call p_lm_gen(theta,legendre_num,polynom)

  write(*, *) polynom(:, 2)

  if (allocated(polynom)) deallocate(polynom, stat=err_polynom)
  if (err_polynom /= 0) print *, "polynom: Deallocation request denied"

  call a_lm_gasdev(4,a_lms,1245,1.d0,1.d0)

  write(*, *) a_lms

end program plm_test


!> Program to perform the Fourier Transform of the
!! linear response function (will be extended for nonlinear
!! response in the future).
PROGRAM fourier_transform
    IMPLICIT NONE
    DOUBLE PRECISION, PARAMETER :: fs2wvnbr = 33356.41
    DOUBLE PRECISION, PARAMETER :: pi = 3.1415926536
    DOUBLE PRECISION :: dt1,dt2,dt3,dummy1,dummy2
    DOUBLE PRECISION :: w1_min, w2_min, w3_min
    DOUBLE PRECISION :: w1_max, w2_max, w3_max
    DOUBLE PRECISION :: dw1, dw2, dw3, w1, w2, w3
    INTEGER :: calc_type
    INTEGER :: itime1,itime2,itime3
    INTEGER :: ntime1,ntime2,ntime3
    INTEGER :: iw1,iw2,iw3
    INTEGER :: nw1,nw2,nw3
    CHARACTER(30) :: filename,junk
    CHARACTER(33) :: outfile
    COMPLEX(8), ALLOCATABLE :: lin_resp(:)
    COMPLEX(8), ALLOCATABLE :: ft_lin_resp(:)
    COMPLEX(8), ALLOCATABLE :: nonlin_resp(:,:,:)
    COMPLEX(8), ALLOCATABLE :: ft_nonlin_resp(:)
    ntime1 = 0 ; ntime2 = 0 ; ntime3 = 0
    nw1 = 0 ; nw2 = 0 ; nw3 = 0

    ! FIGURE OUT WHICH KIND OF RESPONSE TO ANALYZE
    WRITE(*,*) '----------------------------------------------------'
    WRITE(*,*) 'WELCOME, PLEASE CHOOSE ONE OF THE FOLLOWING OPTIONS:'
    WRITE(*,*) 'LINEAR ABSORPTION SPECTRUM:                       1 '
    WRITE(*,*) '3rd ORDER NONLINEAR SPECTRUM:                     2 '
    WRITE(*,*) '----------------------------------------------------'
    READ(*,*) calc_type

    ! COMPUTE 1D FOURIER TRANSFORM
    IF ( calc_type == 1 ) THEN
        WRITE(*,*) 'INSERT LINEAR RESPONSE FILE NAME'
        WRITE(*,*) 'EXPECTING FORMAT time(fs), Re(resp), Im(resp)'
        WRITE(*,*) '----------------------------------------------------'
        READ(*,*) filename
        ! CHOOSE OUTPUT FILE NAME
        WRITE( outfile, '(A,A)') 'FT_',filename

        ! FIGURE OUT NUMBER OF TIME POINTS
        OPEN(UNIT=10, FILE=filename)
        88  CONTINUE
        READ(10,*,END=99,ERR=99) junk
        ntime1 = ntime1 + 1 ; GO TO 88
        99 CONTINUE ; REWIND(10)
        ALLOCATE( lin_resp( 0 : ntime1-1 ) )

        ! READ RESPONSE FUNCTION
        DO itime1 = 0, ntime1-1
            READ(10,*) dt1, dummy1, dummy2
            lin_resp(itime1) = CMPLX( dummy1, dummy2 )
        END DO
        CLOSE(10)
        dt1 = dt1 / (ntime1-1)
        WRITE(*,*) 'FOUND', ntime1, 'TIME POINTS, WITH dt=', dt1

        ! APPLY THE WINDOW FUNCTION
        WRITE(*,*) 'INTRODUCING COSINE WINDOW FUNCTION TO RESPONSE FUNCTION'
        DO itime1 = 0, ntime1-1
            lin_resp(itime1) = lin_resp(itime1) &
                    * COS( pi * itime1/ (2 * (ntime1-1)))
        END DO

        ! CHOOSE FREQUENCY RANGE AND NUMBER OF POINTS
        WRITE(*,*) '----------------------------------------------------'
        WRITE(*,*) 'INSERT FREQUENCY RANGE IN WAVENUMBERS (w_min, w_max, nw)'
        READ(*,*) w1_min, w1_max, nw1
        w1_min = w1_min * 2.d0 * pi / fs2wvnbr ; w1_max = w1_max * 2.d0 * pi / fs2wvnbr
        dw1 = (w1_max - w1_min) / DBLE(nw1)
        ALLOCATE( ft_lin_resp( 0 : nw1 ) )
        ft_lin_resp = 0.d0

        ! DO FOURIER TRANSFORM AT EACH FREQ UENCY
        DO iw1=0, nw1
            w1 = w1_min + DBLE(iw1) * dw1
            ft_lin_resp( iw1 ) = ft( lin_resp, w1, dt1 )
        END DO

        ! WRITE THE FOURIER TRANSFORMED FUNCTION
        OPEN(UNIT=20, FILE=outfile)
        DO iw1 = 0, nw1
            WRITE(20,*) (w1_min + iw1*dw1) * fs2wvnbr / (2.d0 * pi),&
                    REAL(ft_lin_resp(iw1)), AIMAG(ft_lin_resp(iw1))
        END DO
        CLOSE(20)
    END IF

    IF ( calc_type == 2 ) THEN
        WRITE(*,*) 'APOLOGIES, THE NONLINEAR PORTION OF THE CODE HAS &
               NOT BEEN IMPLEMENTED YET :( ...'
        STOP
    END IF

    IF ( ALLOCATED(lin_resp) .EQV. .TRUE. ) THEN
        DEALLOCATE(lin_resp)
    END IF
    IF ( ALLOCATED(nonlin_resp) .EQV. .TRUE. ) THEN
        DEALLOCATE(nonlin_resp)
    END IF

CONTAINS
    !> FT function at frequency \f$omega \f$
    FUNCTION ft( response, w, dt ) RESULT( res )
        IMPLICIT NONE
        INTEGER :: t
        DOUBLE PRECISION, INTENT(IN) :: w, dt
        COMPLEX(8) :: res
        COMPLEX(8), PARAMETER :: eye = (0.d0, 1.d0)
        COMPLEX(8), INTENT(IN) :: response(:)
        res = 0.d0

        DO t = 1, SIZE(response)
            res = res + dt * exp( -eye * w * (t-1) * dt ) * response(t)
        END DO

    END FUNCTION ft

END PROGRAM fourier_transform


cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
cc                                                                    cc
cc                 mnspev : splev test program                        cc
cc                                                                    cc
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      real x(21),y(21),t(20),c(20)
      integer i,i1,i2,ier,j,k,k1,m,n,nk1
      real ai
c  set up the points where the splines will be evaluated.
      m = 21
      do 10 i=1,m
        ai = i-1
        x(i) = ai*0.5e-01
  10  continue
c  main loop for the different spline degrees.
      do 50 k=1,5
        k1 = k+1
c  n denotes the total number of knots.
        n = 2*k1+4
c  set up the knots of the spline
        j = n
c  the boundary knots
        do 20 i=1,k1
          t(i) = 0.
          t(j) = 0.1e+01
          j = j-1
  20    continue
c  the interior knots
        t(k1+1) = 0.1e+0
        t(k1+2) = 0.3e+0
        t(k1+3) = 0.4e+0
        t(k1+4) = 0.8e+0
c  generate the b-spline coefficients.
        nk1 = n-k1
        do 30 i=1,nk1
          ai = i
          c(i) = 0.1e-01*ai*(ai-0.5e01)
  30    continue
c  evaluate the spline.
        call splev(t,n,c,k,x,y,m,ier)
c  print the results.
        write(6,900) k
        write(6,905)
        write(6,910) (t(i),i=1,n)
        write(6,915)
        write(6,920) (c(i),i=1,nk1)
        write(6,925) ier
        write(6,930)
        i2 = 0
        do 40 j=1,7
          i1 = i2+1
          i2 = i1+2
          write(6,935) (i,x(i),y(i),i=i1,i2)
  40    continue
  50  continue
      stop
c  format statements.
 900  format(25h0degree of the spline k =,i2)
 905  format(1x,21hposition of the knots)
 910  format(5x,15f5.1)
 915  format(1x,21hb-spline coefficients)
 920  format(5x,8f9.5)
 925  format(1x,16herror flag ier =,i3)
 930  format(1x,3(7x,1hi,3x,4hx(i),4x,7hs(x(i))))
 935  format(1x,3(i8,f7.2,f11.5))
      end


      subroutine mkherm3(fun,x,nx,y,ny,z,nz,fherm)
C
C  create a data set for Hermite interpolation, from evaluation of
C  function and derivatives.  Function of 3 indep. coordinates.
C
C  input:
C
      external fun                      ! passed real function(x,y,z)
      real x(nx)                        ! x coordinate array  (1st dim)
      real y(ny)                        ! y coordinate array  (2nd dim)
      real z(nz)                        ! z coordinate array  (3rd dim)
C
C  the passed function fun must have the interface:
C
C        real function <name>(x,y,z,dfdx,dfdy,dfdz,
C               d2fdxdy,d2fdxdz,d2fdydz,d3fdxdydz)
C  where x,y,z are input, the function returns the function value,
C  and the arguments dfdx, dfdy and dfdz return as output the function
C  derivative at the point (x,y,z).
C
C  output:
C
      real fherm(0:7,nx,ny,nz)          ! function data & derivatives
C
C  fherm(0,i,j,k) = function value f at x(i),y(j),z(k)
C  fherm(1,i,j,k) = derivative df/dx at x(i),y(j),z(k)
C  fherm(2,i,j,k) = derivative df/dy at x(i),y(j),z(k)
C  fherm(3,i,j,k) = derivative df/dz at x(i),y(j),z(k)
C  fherm(4,i,j,k) = derivative d2f/dxdy at x(i),y(j),z(k)
C  fherm(5,i,j,k) = derivative d2f/dxdz at x(i),y(j),z(k)
C  fherm(6,i,j,k) = derivative d2f/dydz at x(i),y(j),z(k)
C  fherm(7,i,j,k) = derivative d3f/dxdydz at x(i),y(j),z(k)
C
C----------------------------
C
      do iz=1,nz
         do iy=1,ny
            do ix=1,nx
               fherm(0,ix,iy,iz)=
     >            fun(x(ix),y(iy),z(iz),dfdx,dfdy,dfdz,
     >                d2fdxdy,d2fdxdz,d2fdydz,d3fdxyz)
               fherm(1,ix,iy,iz)=dfdx
               fherm(2,ix,iy,iz)=dfdy
               fherm(3,ix,iy,iz)=dfdz
               fherm(4,ix,iy,iz)=d2fdxdy
               fherm(5,ix,iy,iz)=d2fdxdz
               fherm(6,ix,iy,iz)=d2fdydz
               fherm(7,ix,iy,iz)=d3fdxyz
            enddo
         enddo
      enddo
C
      return
      end


c     # ------------------------------------------------------------
c     # Compute edge centered and cell-centered velocity fields
c     #
c     # Edge : Compute velocity from a stream function.
c     # This defines the average velocity at each edge
c     #
c     #      u = curl \Psi  (div u = 0)
c     #
c     # Center : Defines cell-centered velocities from a streamfunction
c     #
c     #      u = n cross grad \Psi  (div u = 0)
c     #
c     # or using basis functions
c     #
c     #      u = u1*t1 + u2*t2   (div u might not be zero)
c     #
c     # NOTE: All arguments to routines here should be in computational
c     # coordinates (x,y) in [0,1]x[0,1].  Mapping from brick domains
c     # to [0,1]x[0,1] should be done from calling routines, as should
c     # any mappings that convert from an orthogonal coordinate system
c     # to a non-orthogonal system.
c     # ------------------------------------------------------------

c     # ------------------------------------------------------------
c     # Edge : u = \nabla cross \Psi - curl \Psi
c     # ------------------------------------------------------------
      subroutine swirl_edge_velocity(x1,y1,x2,y2,ds,vn)
      implicit none

      double precision x1,y1,x2,y2, ds, vn, swirl_psi

      vn = (swirl_psi(x1,y1) - swirl_psi(x2,y2))/ds

      end

c     # ------------------------------------------------------------
c     # Center : u = n cross grad \Psi   (div u = 0)
c     #
c     # Center : u = u1*tau1 + u2*tau2   (div u might not be zero)
c     # ------------------------------------------------------------
      subroutine swirl_center_velocity(x,y,vel)
      implicit none

      double precision x,y,vel(3)

      double precision t1(3), t2(3)
      double precision t1inv(3), t2inv(3)
      double precision nvec(3), gradpsi(3), sv

      double precision p, px, py
      double precision u(2)

      double precision pi, pi2
      common /compi/ pi, pi2

      integer example
      common /example_comm/ example

      integer use_stream
      common /velocity_comm/ use_stream

      integer k

      if (example .eq. 0 .and. use_stream .eq. 1) then
c         # Divergence free velocity field : u = n cross \Psi
          call swirl_psi_derivs(x,y,p,px,py)

          call swirl_contravariant_basis(x,y, t1inv,t2inv)

          do k = 1,3
              gradpsi(k) = px*t1inv(k) + py*t2inv(k)
          end do

c         Outward directed normal
          call swirl_cross(t1inv,t2inv,nvec,sv)

c         # Normalize surface normal
          do k = 1,3
              nvec(k) = nvec(k)/sv
          end do

c         # v = nvec x grad \Psi
          call swirl_cross(nvec,gradpsi,vel,sv)
      else
c         # Vector field defined as u1*tau1 + u2*tau2

          call swirl_covariant_basis(x, y, t1,t2)
          call swirl_velocity_components(x,y,u)

          do k = 1,3
              vel(k) = u(1)*t1(k) + u(2)*t2(k)
          enddo
      endif

      end

      subroutine swirl_covariant_basis(x,y,t1,t2)
      implicit none

      double precision x,y,t1(3),t2(3)
      double precision t(3,2),tinv(3,2), tderivs(3,2,2)
      integer flag, k

c     # Compute covariant derivatives only
      flag = 1
      call swirl_basis_complete(x,y, t, tinv, tderivs, flag)

      do k = 1,3
          t1(k) = t(k,1)
          t2(k) = t(k,2)
      enddo

      end

      subroutine swirl_contravariant_basis(x,y,t1inv,t2inv)
      implicit none

      double precision x,y
      double precision t1inv(3), t2inv(3)
      double precision t(3,2), tinv(3,2), tderivs(3,2,2)
      integer k, flag

      flag = 3
      call swirl_basis_complete(x,y, t, tinv,tderivs, flag)

      do k = 1,3
          t1inv(k) = tinv(k,1)
          t2inv(k) = tinv(k,2)
      end do

      end

      subroutine swirl_christoffel_sym(x,y,g)
      implicit none

      double precision x, y
      double precision g(2,2,2)

      double precision swirl_dot

      double precision pi, pi2
      common /compi/ pi, pi2

      double precision t(3,2), tinv(3,2), tderivs(3,2,2)
      double precision s(3,2), tij(3), sk(3)

      integer i,j,k, m, flag

c     # Compute covariant and derivatives

      flag = 7
      call swirl_basis_complete(x,y, t, tinv,tderivs, flag)

      do k = 1,3
          s(k,1) = tinv(k,1)
          s(k,2) = tinv(k,2)
      end do

      do i = 1,2
          do j = 1,2
              do k = 1,2
                  do m = 1,3
                      tij(m) = tderivs(m,i,j)
                      sk(m) = s(m,k)
                  enddo
                  g(i,j,k) = swirl_dot(tij,sk)
              enddo
          enddo
      enddo

      end

      double precision function swirl_divergence(x,y)
      implicit none

      double precision x,y

      double precision u(2), uderivs(4), g(2,2,2)
      double precision D11, D22

c     # Get g(i,j,k), g = \Gamma(i,j,k)
      call swirl_velocity_derivs(x,y,u,uderivs)
      call swirl_christoffel_sym(x,y,g)

      D11 = uderivs(1) + u(1)*g(1,1,1) + u(2)*g(1,2,1)
      D22 = uderivs(4) + u(1)*g(2,1,2) + u(2)*g(2,2,2)

      swirl_divergence = D11 + D22

c      swirl_divergence = g(1,1,1)    !! 0
c      swirl_divergence = g(1,1,2)    !! 1.67865983e+01
c      swirl_divergence = g(1,2,1)    !! 2.74215323e+00
c      swirl_divergence = g(1,2,2)    !! 0
c      swirl_divergence = g(2,1,1)    !! 2.74215323e+00
c      swirl_divergence = g(2,1,2)    !! 0
c      swirl_divergence = g(2,2,1)    !! 0
c      swirl_divergence = g(2,2,2)    !! 0

      end

c     # ----------------------------------------------------------------
c     # RHS functions for ODE solver DOPRI5  (original ode45)
c     #        -- divfree field
c     #        -- field with divergence
c     # ----------------------------------------------------------------

      subroutine swirl_rhs_divfree(n,t,sigma,f,rpar,ipar)
      implicit none

      integer n, ipar(2)
      double precision t, sigma(n), f(n), rpar

      double precision x,y
      double precision p, px, py
      double precision t1(3), t2(3), t1xt2(3), w
      double precision u(2)

      integer example, use_stream

      x = sigma(1)
      y = sigma(2)

      example = ipar(1)
      use_stream = ipar(2)

      if (example .eq. 0 .and. use_stream .eq. 1) then
          call swirl_psi_derivs(x,y,p,px,py)

c         # Compute u dot grad q in computational coordinates
          call swirl_covariant_basis(x,y,t1,t2)
          call swirl_cross(t1,t2,t1xt2,w);

c         # Evolve contravariant components of velocity field
          u(1) = -py/w
          u(2) = px/w
      else
          call swirl_velocity_components(x,y,u)
      endif

c     # We are tracing these back, so use negative velocities
      f(1) = -u(1)
      f(2) = -u(2)

      end

      subroutine swirl_rhs_nondivfree(n,t,sigma,f,rpar,ipar)
      implicit none

      integer n, ipar(2)
      double precision t, sigma(n), f(n), rpar

      double precision x,y, q
      double precision u(2)
      double precision divu, swirl_divergence

      double precision t1(3), t2(3), t1xt2(3), w
      double precision p,px,py
      integer example, use_stream

c     # Track evolution of these three quantities

      x = sigma(1)
      y = sigma(2)
      q = sigma(3)

      example = ipar(1)
      use_stream = ipar(2)

      if (example .eq. 0 .and. use_stream .eq. 1) then
          call swirl_psi_derivs(x,y,p,px,py)

c         # Compute u dot grad q in computational coordinates
          call swirl_covariant_basis(x,y,t1,t2)
          call swirl_cross(t1,t2,t1xt2,w);

c         # Evolve contravariant components of velocity field
          u(1) = -py/w
          u(2) = px/w
      else
          call swirl_velocity_components(x,y,u)
      endif

      divu = swirl_divergence(x,y)

      f(1) = u(1)
      f(2) = u(2)
      f(3) = -divu*q   !! Non-conservative case

      end

c     # ----------------------------------------------------------------
c     # Utility functions
c     # ----------------------------------------------------------------

      subroutine swirl_cross(u,v,uxv,w)
      implicit none

      double precision u(3),v(3),uxv(3),w, swirl_dot

      uxv(1) =   u(2)*v(3) - u(3)*v(2)
      uxv(2) = -(u(1)*v(3) - u(3)*v(1))
      uxv(3) =   u(1)*v(2) - u(2)*v(1)

      w = swirl_dot(uxv,uxv)
      w = sqrt(w)

      end

      double precision function swirl_dot(u,v)
      implicit none

      double precision u(3),v(3)

      swirl_dot = u(1)*v(1) + u(2)*v(2) + u(3)*v(3)

      end


program test
! Test the CIJ_pnning_VTI function

use anisotropy_ajn

implicit none

real(8) :: C(6,6),vp,vs,rho,xi,phi

! At 2750 in AK135
vp = 13650.
vs = 7249.
rho = 5423.
xi = 1.3
phi = 0.8

C = CIJ_panning_VTI(vp,vs,rho,xi,phi)

write(*,*) C

end program test


      subroutine system_ccfft(init,isign,n,scale,x,y,
     &           table,work,isys,ntable,nwork)
****************************************************
*** Written by Lin-Wang Wang, 2001
*************************************************************************
**  copyright (c) 2003, The Regents of the University of California,
**  through Lawrence Berkeley National Laboratory (subject to receipt of any
**  required approvals from the U.S. Dept. of Energy).  All rights reserved.
*************************************************************************

      implicit none
      integer init,isign,n,isys,ntable,nwork
      real*8 scale,table(1),work(1)
      real*8 x(1),y(1)
cccccccc complex to complex 1D FFT

cccccc for T3E
c      if(init.eq.1) then
c      call ccfft(0,n,scale,0,0,table,0,0)
c      else
c      call ccfft(isign,n,scale,x,y,table,work,isys)
c      endif
cccccccccccccccccccccc
cccccc for IBM SP2, essl lib
      if(init.eq.1) then
      call dcft(1,0,1,0,0,1,0,
     &    n,1,-isign,scale,table,ntable,0,0)
      else
      call dcft(0,x,1,0,y,1,0,n,1,-isign,scale,
     &    table,ntable,work,nwork)
      endif
cccccccccccccccccccccccccccccccccccc
ccccccccc  for Intel KML lib
c       if(init.eq.1) then
c       call zfft1d(y,n,0,table)
c       else
c       do i=1,2*n
c       y(i)=x(i)
c       enddo
c       call zfft1d(y,n,isign,table)
c       if(isign.eq.1) then
c       do i=1,2*n
c       y(i)=y(i)*n*scale
c       enddo
c       endif
c       endif
ccccccccccccccccccccccccccccccccccccccc

      return
      end


c-----multiplication of k-slash from the left with a spinor sp
C-----and return resultant spinor f. Weyl representation
      subroutine kslashU(k,sp,f)
      implicit none
      include 'swapxz.f'
      double complex sp(4),k(4),f(4),czip,im,kslash(4,4),E,kx,ky,kz
      integer i,j
      parameter(czip=(0d0,0d0),im=(0d0,1d0))

      logical,save::first
      data first/.true./

      if (first) then
      write(6,*) 'kslashU:swapxz=',swapxz
      first=.false.
      endif

      if (swapxz) then
C----create kslash after performing the swap (x<->z),(y->-y)
      E=k(4)
      kx=+k(3)
      ky=-k(2)
      kz=+k(1)
      else
      E=k(4)
      kx=+k(1)
      ky=+k(2)
      kz=+k(3)
      endif

      kslash(1,1)=czip
      kslash(1,2)=czip
      kslash(1,3)=E+kz
      kslash(1,4)=kx-im*ky

      kslash(2,1)=czip
      kslash(2,2)=czip
      kslash(2,3)=kx+im*ky
      kslash(2,4)=E-kz

      kslash(3,1)=E-kz
      kslash(3,2)=-kx+im*ky
      kslash(3,3)=czip
      kslash(3,4)=czip

      kslash(4,1)=-kx-im*ky
      kslash(4,2)=E+kz
      kslash(4,3)=czip
      kslash(4,4)=czip

      do i=1,4
      f(i)=czip
      do j=1,4
      f(i)=f(i)+kslash(i,j)*sp(j)
      enddo
      enddo
      return
      end


      SUBROUTINE CANOCAF(IR,INW,N,LAGH1,IP0,CCV,L,AIC,OAIC,MO,OSD,AAO,
     *NC,N1,N2,VV,Z,Y,XX,NDT,X3,X3MIN,MIN3,F,M1NH,NH,G,IAW,VF,
     *LMAX,MJ0,MJ1)
C
      INCLUDE 'timsac_f.h'
C
cc	PROGRAM CANOCA
C     PROGRAM 74.2.1. CANONICAL CORRELATION ANALYSIS OF VECTOR TIME SERI
C-----------------------------------------------------------------------
C     ** DESIGNED BY H. AKAIKE, THE INSTITUTE OF STATISTICAL MATHEMATICS
C     ** PROGRAMMED BY E. ARAHATA, THE INSTITUTE OF STATISTICAL MATHEMAT
C         TOKYO
C     ** DATE OF THE LATEST REVISION: MARCH 25, 1977
C     ** THIS PROGRAM WAS ORIGINALLY PUBLISHED IN
C         "TIMSAC-74 A TIME SERIES ANALYSIS AND CONTROL PROGRAM PACKAGE(1
C         BY H. AKAIKE, E. ARAHATA AND T. OZAKI, COMPUTER SCIENCE MONOGRA
C         NO.5, MARCH 1975, THE INSTITUTE OF STATISTICAL MATHEMATICS
C     ** FOR THE BASIC THEORY SEE "CANONICAL CORRELATION ANALYSIS OF TIM
C         AND THE USE OF AN INFORMATION CRITERION" BY H. AKAIKE, IN
C         "SYSTEM IDENTIFICATION: ADVANCES AND CASE STUDIES" R. K. MEHRA
C         D. G. LAINIOTIS EDS. ACADEMIC PRESS, NEW YORK, 1976
C-----------------------------------------------------------------------
C     THIS PROGRAM DOES CANONICAL CORRELATION ANALYSIS OF AN IR-DIMENSIO
C     MULTIVARIATE TIME SERIES Y(I) (I=1,N).
C
C     FIRST AR-MODEL IS FITTED BY THE MINIMUM  A I C  PROCEDURE.
C     THE RESULTS ARE USED TO ORTHO-NORMALIZE THE PRESENT AND PAST VARIA
C     THE PRESENT AND FUTURE VARIABLES ARE TESTED SUCCESSIVELY TO DECIDE
C     ON THE DEPENDENCE OF THEIR PREDICTORS. WHEN THE LAST DIC (AN INFOR
C     CRITERION) IS NEGATIVE THE PREDICTOR OF THE VARIABLE IS DECIDED
C     TO BE LINEARLY DEPENDENT ON THE ANTECEDENTS.
C
C     THE STRUCTURAL CHARACTERISTIC VECTOR H OF THE CANONICAL MARKOVIAN
C     REPRESENTATION AND THE ESTIMATE OF THE TRANSITION MATRIX F, IN
C     VECTOR FORM, ARE PUNCHED OUT. THE ESTIMATE OF THE INPUT MATRIX G A
C     THE COVARIANCE MATRIX C OF THE INNOVATION, OBTAINED BY USING
C     THE F-MATRIX AND THE AR-MODEL, ARE ALSO PUNCHED OUT.
C
C     INPUTS REQUIRED:
C     IR:		 DIMENSION OF Y(I)
C     INW(K)(K=1,IP):	 INW(K)=J MEANS THAT THE K-TH COMPONENT OF Y(I)
C          IS THE J-TH COMPONENT OF THE ORIGINAL RECORD Z(I) USED FOR
C          THE COMPUTATION OF THE COVARIANCE SEQUENCE CZZ(I).
C
C     ALSO THE FOLLOWING INPUTS ARE REQUESTED BY THE SUBROUTINE	 R E C O
C     THESE INPUTS CAN BE OBTAINED AS THE OUTPUTS OF THE TIMSAC
C     PROGRAM 5.1.2 ( MULCOR ).
C     N:		 DATA LENGTH
C     LAGH:		 MAXIMUM LAG OF COVARIANCE
C     IP0:		 DIMENSION OF THE ORIGINAL RECORD
C     CZZ(I)(I=0,LAGH):	 COVARIANCE MATRIX SEQUENCE OF Z(I) GIVEN IN THE
C         OF THE SUCCESSION OF THE SEQUENCES OF COVARIANCES BETWEEN THE
C         C-TH COMPONENTS OF Z(I), ARRANGED IN THE ORDER (R=1,C=1),(R=2,
C         (R=2,C=1),(R=1,C=2),(R=3,C=3),(R=3,C=1),(R=1,C=3),(R=3,C=2),(R
C         ...... EACH SEQUENCE HAS THE HEADING (R,C).
C         THE (J+1)ST ELEMENT OF THE COVARIANCE SEQUENCE WITH R=K AND C=
C         IS AN ESTIMATE OF E(Z(I+J,K)*Z(I,L)), WHERE Z(I,K) DENOTES
C         THE K-TH COMPONENT OF Z(I).
C
cc      !DEC$ ATTRIBUTES DLLEXPORT :: CANOCAF
C
cxx      IMPLICIT REAL*8(A-H,O-Z)
cc      DIMENSION Y(91),Z(91),WL(91)
cc      DIMENSION CV(25,7,7)
cc      DIMENSION XX(91),X3(91),F(91),VF(637)
cc      DIMENSION U(91,46),V(46,46),VV(46,46)
cc      DIMENSION AST1(91,7,7)
cc      DIMENSION NH(91),IH(91)
cc      DIMENSION FL(46,46)
cc      DIMENSION RGT(91,91),FRG(46,91)
cc      DIMENSION VTG(91),SR(46),ZZ(46),SF(46),SFRG(91)
cc      DIMENSION INW(7),C1(7,7)
cc      DIMENSION OSD(7,7),AO(13,7,7)
cc      DIMENSION G(46,7)
cxx      DIMENSION Y(MJ1,MJ1),Z(MJ1,MJ1),WL(MJ1)
cxx      DIMENSION CV(LMAX*2+1,IR,IR)
cxx      DIMENSION XX(MJ1,MJ1),X3(MJ1,MJ1),F(MJ1,MJ1),VF(MJ1*MJ1)
cxx      DIMENSION U(MJ1,MJ1),V(MJ1,MJ1),VV(MJ1,MJ1,MJ1)
cxx      DIMENSION AST1((LMAX+1)*LMAX,IR,IR)
cxx      DIMENSION NH(MJ1),IH(MJ1)
cxx      DIMENSION FL(MJ1,MJ1)
cxx      DIMENSION RGT(MJ1,MJ1),FRG(MJ1,MJ1)
cxx      DIMENSION VTG(MJ1),SR(MJ1),ZZ(MJ1),SF(MJ1),SFRG(MJ1)
cxx      DIMENSION INW(IR),C1(IP0,IP0)
cxx      DIMENSION OSD(IR,IR),AO(MJ0,IR,IR),AAO(MJ0,IR,IR)
cxx      DIMENSION G(MJ1,IR)
C
cxx      DIMENSION CCV(LAGH1,IP0,IP0)
cxx      DIMENSION AIC(MJ0)
cxx      DIMENSION N1(MJ1),N2(MJ1),NDT(MJ1,MJ1)
cxx      DIMENSION X3MIN(MJ0*IR),MIN3(MJ0*IR)
      INTEGER :: IR,  INW(IR), N, LAGH1, IP0, L, MO, NC, N1(MJ1),
     1           N2(MJ1), NDT(MJ1,MJ1), MIN3(MJ0*IR), M1NH,
     2           NH(MJ1), IAW, LMAX, MJ0, MJ1
      REAL(8) :: CCV(LAGH1,IP0,IP0), AIC(MJ0), OAIC, OSD(IR,IR),
     1           AAO(MJ0,IR,IR), VV(MJ1,MJ1,MJ1), Z(MJ1,MJ1),
     2           Y(MJ1,MJ1), XX(MJ1,MJ1), X3(MJ1,MJ1),
     3           X3MIN(MJ0*IR), F(MJ1,MJ1), G(MJ1,IR), VF(MJ1*MJ1)
c
      INTEGER :: IH(MJ1)
      REAL(8) :: WL(MJ1), CV(LMAX*2+1,IR,IR), U(MJ1,MJ1), V(MJ1,MJ1),
     1           AST1((LMAX+1)*LMAX,IR,IR), FL(MJ1,MJ1), RGT(MJ1,MJ1),
     2           FRG(MJ1,MJ1), VTG(MJ1), SR(MJ1), ZZ(MJ1), SF(MJ1),
     3           SFRG(MJ1), C1(IP0,IP0), AO(MJ0,IR,IR),
     4           CST0, CST1, CST2, XL, YL, R11C, FCT, SS, FSRINP,
     5           SSFR2, SG, EM, EN, ANDT, AII
C
cc      COMMON /COM9/AST1
cc      COMMON /COM10/CV
cc      COMMON /COM11/RGT
cc      COMMON /COM19/U
cc      COMMON /COM20/V
cc      COMMON /COM21/VV
cc      COMMON /COM25/FL
cc      EQUIVALENCE (AST1(1,1,1),VF(1))
C
C     INPUT / OUTPUT DATA FILE OPEN
cc      CHARACTER(100) DFNAM
cc      CALL SETWND
cc      DFNAM='canoca.out'
cc      CALL FLOPN3(DFNAM,NFL)
cc      IF (NFL.EQ.0) GO TO 999
C
cc      MJ1=46
cc      MJ2=91
cc      MJ=7
cc      MJ0=13
      NC = 0
      CST0=0.0D-00
      CST1=1.0D-00
      CST2=2.0D-00
cc      DO 3111 I=1,46
cc      DO 3112 J=1,7
      DO 3111 I=1,MJ1
      DO 3112 J=1,IR
      G(I,J)=CST0
 3112 CONTINUE
c---
      DO 3113 J=1,MJ1
      F(I,J)=CST0
 3113 CONTINUE
c---
 3111 CONTINUE
C     INITIAL CONDITION INPUT
cc      READ(5,1) IR
      IL=0
      IP=IR
cc      READ(5,1) (INW(I),I=1,IP)
cc      WRITE(6,11114)
cc      WRITE(6,11111)
cc      WRITE(6,11113) IR
cc      LCV=24
      LCV=LMAX*2
      LCV1=LCV+1
C     AUTO COVARIANCE INPUT
cc      CALL RECOVA(LCV1,IP0,N)
cxx      DO 90 I=1,MIN(LCV1,LAGH1)
cxx         DO 90 J=1,IP
      DO 92 I=1,MIN(LCV1,LAGH1)
         DO 91 J=1,IP
         DO 90 K=1,IP
            CV(I,J,K) = CCV(I,J,K)
   90    CONTINUE
   91    CONTINUE
   92 CONTINUE
C     L (UPPER BOUND OF AR-ORDER) COMPUTATION
cc      LMAX=12
      XL=2*N
      XL=DSQRT(XL)
      YL=IR
cxx      J=XL/YL
      J=INT(XL/YL)
      L= MIN0(LMAX,J)
      L1=L+1
C     MATRIX ARRANGEMENT
      DO 10 II=1,LCV1
cxx      DO 20 I=1,IP0
      DO 11 I=1,IP0
      DO 20 J=1,IP0
cxx   20 C1(I,J)=CV(II,I,J)
      C1(I,J)=CV(II,I,J)
   20 CONTINUE
   11 CONTINUE
C     MATRIX REARRANGEMENT BY INW
C     COMMON SUBROUTINE CALL
cc      CALL REARRA(C1,INW,IP0,IP,MJ)
      CALL REARRA(C1,INW,IP0,IP)
cxx      DO 21 I=1,IP
      DO 12 I=1,IP
      DO 21 J=1,IP
cxx   21 CV(II,I,J)=C1(I,J)
      CV(II,I,J)=C1(I,J)
   21 CONTINUE
   12 CONTINUE
   10 CONTINUE
cc      WRITE(6,259) (INW(I),I=1,IP)
      IAW=0
      ID=IR
      LMAX2=(LMAX+1)*LMAX
C     AR-MODEL FITTING BY THE MINIMUM AIC PROCEDURE
C     COMMON SUBROUTINE CALL
cc      CALL NWFPEC(OSD,AO,L,IR,IL,N,MO,MJ0,MJ)
      CALL NWFPEC(AIC,OAIC,CV,AST1,OSD,AO,AAO,L,IR,IL,N,MO,MJ0,
     * LMAX2,LCV1)
C     MO: MAICE AR-MODEL ORDER DETERMINED BY NWFPEC
C     RGT=R12*G' COMPUTATION
cc      CALL SBRUGT(MO,ID)
      CALL SBRUGT(MO,ID,AST1,CV,RGT,MJ1,IR,LMAX2,LCV1)
      MMMH=(MO+1)*ID
      NINEW=MMMH
C     FRG' COMPUTATION
C     M1: NUMBER OF VARIABLE IN THE FUTURE SET
C     M2: NUMBER OF VARIABLES IN THE PAST SET =MMMH
      M1=1
      R11C=CV(1,1,1)
c-----------
cxx      DO 22 I=1,MJ1
cxx         DO 22 J=1,MJ1
cxx            FL(I,J)=CST0
cxx   22 CONTINUE
      FL(1:MJ1,1:MJ1)=CST0
c------------
      FL(1,1)=CST1/DSQRT(R11C)
      FCT=FL(1,1)
      M2=(MO+1)*ID
      DO 100 J=1,M2
      FRG(1,J)=FCT*RGT(1,J)
  100 CONTINUE
      ISW=0
      NINEW0=2
      DO 191 I=1,IR
cxx  191 NH(I)=I
      NH(I)=I
  191 CONTINUE
cxx      DO 634 I=1,MMMH
cxx  634 IH(I)=0
      IH(1:MMMH)=0
  500 M1=M1+1
      M2=MMMH
      M=M1+M2
      MP1=M1+1
C     COVARIANCE MATRIX ARRANGEMENT
      NINEWI=NINEW0
      DO 636 I=NINEWI,MMMH
      IF(IH(I).EQ.0) GO TO 637
C     TEST OF EXHAUSTION OF FUTURE VARIABLES
      IF(I.GE.MMMH) GO TO 1140
      NINEW0=NINEW0+1
      GO TO 636
  637 NH(M1)=I
      GO TO 638
  636 CONTINUE
  638 CONTINUE
C     THE AUGMENTED FRG' MATRIX (F+)(G+)G' IS OBTAINED BY THE
C     BORDERING TECHNIQUE:
C                           +-         -+
C                  (F+) = I F    0     I
C                           I             I
C                           I             I
C                           I SF'  SG  I
C                           +-         -+,
C                           +-         -+
C              (RVV+) = I RVV  SR I
C                           I             I
C                           I             I
C                           I SR'  SS  I
C                           +-        - +,
C              (F+)(RVV+)(F+)'=I,
C                           +-         -+
C                  (R+) = I    R      I
C                           I            I
C                           I            I
C                           I    ST'    I
C                           +-         -+,
C             AND
C                           +-         -+
C          (F+)(R+)G' = I   FRG'    I
C                           I             I
C                           I             I
C                           I  LRFRG  I
C                           +-         -+,
C        FRG' IS STORED AS FRG.
C     SR,SS,VTG=(ST)'G' ARRANGEMENT
      II=NH(M1)
      IDB=II/ID
      IRES=II-IDB*ID
      IF(IRES.NE.0) IDB=IDB+1
      IF(IRES.EQ.0) IRES=ID
      DO 640 J=1,M2
cxx  640 VTG(J)=RGT(II,J)
      VTG(J)=RGT(II,J)
  640 CONTINUE
      DO 642 J=1,M1
      JJ=NH(J)
      JDB=JJ/ID
      JRES=JJ-JDB*ID
      IF(JRES.NE.0) JDB=JDB+1
      IF(JRES.EQ.0) JRES=ID
      IJDB=IDB-JDB
      IF(IJDB.LT.0) GO TO 646
      SR(J)=CV(IJDB+1,IRES,JRES)
      GO TO 642
  646 IJDB1=-IJDB+1
      SR(J)=CV(IJDB1,JRES,IRES)
  642 CONTINUE
      SS=SR(M1)
C     ZZ= F*SR COMPUTATION (F STORED AS FL IN COMMON AREA)
      MM1=M1-1
cc      CALL BLMLVC(SR,ZZ,MM1)
      CALL BLMLVC(SR,ZZ,MM1,FL,MJ1)
C     INNER PRODUCT OF FL*SR COMPUTATION
C     COMMON SUBROUTINE CALL
      CALL INNERP(ZZ,ZZ,FSRINP,MM1)
C     SG COMPUTATION
      SSFR2=SS-FSRINP
cc      IF  (SSFR2) 731,731,732
      IF  (SSFR2 .LT. 0) GO TO 731
      IF  (SSFR2 .EQ. 0) GO TO 731
      IF  (SSFR2 .GT. 0) GO TO 732
  731 SG=CST0
      GO TO 733
  732 SG=CST1/DSQRT(SSFR2)
C     SF=-(F'*(F*SR))*SG COMPUTATION
cc  733 CALL AVMLVC(ZZ,SF,MM1)
  733 CALL AVMLVC(ZZ,SF,MM1,FL,MJ1)
      DO 350 I=1,MM1
cxx  350 SF(I)=-SF(I)*SG
      SF(I)=-SF(I)*SG
  350 CONTINUE
C     F AUGMENTATION
      DO 360 J=1,MM1
cxx  360 FL(M1,J)=SF(J)
      FL(M1,J)=SF(J)
  360 CONTINUE
      FL(M1,M1)=SG
C     SFRG=SF'*R12*G' COMPUTATION
cc      CALL VECMTX(SF,SFRG,NH,MM1,M2)
      CALL VECMTX(SF,SFRG,NH,RGT,MM1,M2,MJ1)
C      LRFRG=SFRG+SG*VTG (=THE LAST ROW OF (F+)(R+)G')
      DO 370 I=1,M2
cxx  370 FRG(M1,I)=SFRG(I)+SG*VTG(I)
      FRG(M1,I)=SFRG(I)+SG*VTG(I)
  370 CONTINUE
cxx      DO 230 I=1,M2
      DO 231 I=1,M2
      DO 230 J=1,M1
      U(I,J)=FRG(J,I)
  230 CONTINUE
  231 CONTINUE
C     CANONICAL WEIGHTS FOR THE SET OF ORTHO-NORMALIZED FUTURE VARIABLES
C     ARE OBTAINED IN V(COMMON AREA).
C     CANONICAL CORRELATION COEFFICIENTS ARE RETURNED IN Z.
C     COMMON SUBROUTINE CALL
cc      CALL MSVD(Z,M2,M1)
      NC = NC+1
      CALL MSVD(U,V,Z(1,NC),M2,M1,MJ1,MJ1)
C     W=V'*FL : CANONICAL WEIGHTS COMPUTATION
cc      CALL MWTFL(M1)
      CALL MWTFL(V,VV(1,1,NC),M1,FL,MJ1)
      DO 260 J=1,M1
cc  260 Y(J)=Z(J)*Z(J)
cxx  260 Y(J,NC)=Z(J,NC)*Z(J,NC)
      Y(J,NC)=Z(J,NC)*Z(J,NC)
  260 CONTINUE
cc      WRITE(6,6)
cc      WRITE(6,7) M1
cc      WRITE(6,8) M2
      N1(NC)=M1
      N2(NC)=M2
cc      WRITE(6,9) N
cc      WRITE(6,35)
cc      DO 8100 I=1,M1
cc 8100 WRITE(6,8200) I,(VV(I,J),J=1,M1)
      EM=M
      EN=N
      J=M1
      WL(J+1)=CST1
cc   42 WL(J)=WL(J+1)*(CST1-Y(J))
   42 WL(J)=WL(J+1)*(CST1-Y(J,NC))
      J=J-1
      IF(J.GT.0) GO TO 42
      DO 45 J=1,M1
      IF(WL(J).GT.CST0) GO TO 145
cc      XX(J)=9999.0D-00
      XX(J,NC)=9999.0D-00
      GO TO 45
cc  145 XX(J)=-EN*DLOG(WL(J))
  145 XX(J,NC)=-EN*DLOG(WL(J))
   45 CONTINUE
cc      NDT=M1*M2
cc      ANDT=NDT
      NDT(1,NC)=M1*M2
      ANDT=NDT(1,NC)
C     DIC(=CHI-SQUARE-2.0*D.F.) COMPUTATION
cc      X3(1)=XX(1)-CST2*ANDT
      X3(1,NC)=XX(1,NC)-CST2*ANDT
cc      WRITE(6,49)
      J=0
cc      WRITE(6,50) J,Z(1),Y(1),XX(1),NDT,X3(1)
cc      X3MIN=X3(1)
cc      MIN3=0
      X3MIN(NC)=X3(1,NC)
      MIN3(NC)=0
      IF(M1.LT.2) GO TO 4110
      DO 51 J=2,M1
      J1=J-1
cc      NDT=(M1-J1)*(M2-J1)
cc      ANDT=NDT
cc      X3(J)=XX(J)-CST2*ANDT
cc   51 WRITE(6,50) J1,Z(J),Y(J),XX(J),NDT,X3(J)
      NDT(J,NC)=(M1-J1)*(M2-J1)
      ANDT=NDT(J,NC)
      X3(J,NC)=XX(J,NC)-CST2*ANDT
   51 CONTINUE
      DO 4300 J=2,M1
cc      IF(X3(J).GE.X3MIN) GO TO 4300
cc      X3MIN=X3(J)
cc      MIN3=J-1
      IF(X3(J,NC).GE.X3MIN(NC)) GO TO 4300
      X3MIN(NC)=X3(J,NC)
      MIN3(NC)=J-1
 4300 CONTINUE
cc 4110 WRITE(6,4410) X3MIN,MIN3
 4110 CONTINUE
cc      WRITE(6,11112)
      IF(NINEW0.EQ.NINEW) GO TO 6999
      IF(X3(M1,NC).GT.CST0) GO TO 110
 6999 M1M=M1-1
      IF(M1M.LE.0) GO TO 110
C     TRANSITION MATRIX (F) COMPUTATION
cc      AII=CST1/VV(M1,M1)
      AII=CST1/VV(M1,M1,NC)
      DO 5100 I=1,M1M
      IAW=IAW+1
cc      F(I)=-VV(M1,I)*AII
cc      VF(IAW)=F(I)
      F(I,NC)=-VV(M1,I,NC)*AII
      VF(IAW)=F(I,NC)
 5100 CONTINUE
cc      WRITE(6,5200)
C     COMMON SUBROUTINE CALL
cc      CALL SUBVCP   (F,M1M)
      M1=M1-1
      ISW=ISW+1
      DO 1120 I=NINEW0,MMMH,ID
cxx 1120 IH(I)=1
      IH(I)=1
 1120 CONTINUE
      IF(ISW.GE.ID) GO TO 1100
  110 IF(NINEW0.GE.NINEW) GO TO 1100
      NINEW0=NINEW0+1
      GO TO 500
 1140 M1=M1-1
cc 1100 WRITE(6,1130)
 1100 CONTINUE
C     STRUCTURAL CHARACTERISTIC VECTOR PRINT AND PUNCH OUT
      M1NH=M1
cc      WRITE(6,1131) (NH(I),I=1,M1)
cc      WRITE(7,1) IR,M1
cc      WRITE(7,1) (NH(I),I=1,M1)
C     F MATRIX (IN VECTOR FORM) PUNCH OUT
cc      WRITE(7,2) (VF(I),I=1,IAW)
C     INPUT MATRIX (G) COMPUTATION
cc 1011 CALL SUBBMA(AO,G,NH,M1,ID,MO,MJ0,MJ)
cxx 1011 CALL SUBBMA(AO,G,NH,M1,ID,MO,MJ1,MJ0)
      CALL SUBBMA(AO,G,NH,M1,ID,MO,MJ1,MJ0)
C     INPUT MATRIX (G) PRINT AND PUNCH OUT
cc      WRITE(6,61)
C     COMMON SUBROUTINE CALL
cc      CALL SUBMPR(G,M1,ID,MJ1,MJ)
cc      IRP1=IR+1
cc      IF(IRP1.GT.M1) GO TO 1400
cc      DO 2010 I=IRP1,M1
cc 2010 WRITE(7,2) (G(I,J),J=1,ID)
cc 1400 CALL FLCLS3(NFL)
      CONTINUE
      RETURN
cxx    1 FORMAT(16I5)
cxx    2 FORMAT(4D20.10)
cxx    6 FORMAT(//1H ,21HCANONICAL CORRELATION)
cxx    7 FORMAT(/1H ,'NUMBER OF PRESENT AND FUTURE VARIABLES',2X,
cxx     A'M1=',I5)
cxx    8 FORMAT(/1H ,'NUMBER OF PRESENT AND PAST VARIABLES',4X,
cxx     A'M2=',I5)
cxx    9 FORMAT(/1H ,'DATA LENGTH=N=',I6)
cxx   35 FORMAT(/1H ,'FUTURE SET CANONICAL WEIGHTS, ROWWISE')
cxx   49 FORMAT(/1H ,5X,8HORDER(P),4X,11HCANONICAL R,3X,9HR-SQUARED,3X,
cxx     A 10HCHI-SQUARE,3X,6HN.D.F.,2X,23HDIC (P)(=CHI**2-2*D.F.))
cxx   50 FORMAT(/1H ,10X,I3,4X,F8.4,4X,F8.3,7X,F8.2,4X,I6,3X,F10.4)
cxx 4410 FORMAT(/1H ,'MINIMUM DIC(P) =',F12.2,1X,'ATTAINED AT P='
cxx     A,I5)
cxx 5200 FORMAT(/1H ,5X,'F(I)')
cxx 1130 FORMAT(/1H ,'STRUCTURAL CHARACTERISTIC VECTOR',
cxx     A' (H(I),I=1,P)')
cxx 1131 FORMAT(1H ,4X,10I12)
cxx   61 FORMAT(/1H ,'G-MATRIX')
cxx  259 FORMAT(1H ,6HINW(I),5X,10I5)
cxx 8200 FORMAT(/1H ,I5,10D12.5,/(1H ,5X,10D12.5))
cxx11111 FORMAT(/1H ,'INITIAL AUTO REGRESSIVE MODEL FITTING ',
cxx     A'BY THE MINIMUM AIC PROCEDURE.')
cxx11112 FORMAT(1H ,8X,'        THE VALUE OF CHI-SQUARE AND DIC (P) ',
cxx     A'CORRESPONDING TO CANONICAL R=1.000 ',
cxx     A'SHOULD BE IGNORED')
cxx11114 FORMAT(1H ,'PROGRAM 74.2.1. CANOCA')
cxx11113 FORMAT(/1H ,'IR=',I5)
      END
C
cc      SUBROUTINE AVMLVC(Y,Z,MM)
      SUBROUTINE AVMLVC(Y,Z,MM,FL,MJ1)
C     Z=FL'*Y
C     FL: LOWER TRIANGLE
C     Y: VECTOR
cxx      IMPLICIT REAL*8(A-H,O-Z)
cxx      DIMENSION Y(MM),Z(MM)
cc      DIMENSION FL(46,46)
cc      COMMON /COM25/FL
cxx      DIMENSION FL(MJ1,MJ1)
      INTEGER :: MM ,MJ1
      REAL(8) :: Y(MM), Z(MM), FL(MJ1,MJ1)
      REAL(8) :: CST0, SUM
      CST0=0.0D-00
      DO 10 I=1,MM
      SUM=CST0
      DO 11 J=I,MM
cxx   11 SUM=SUM+FL(J,I)*Y(J)
      SUM=SUM+FL(J,I)*Y(J)
   11 CONTINUE
      Z(I)=SUM
   10 CONTINUE
      RETURN
      END
C
cc      SUBROUTINE BLMLVC(Y,Z,MM)
      SUBROUTINE BLMLVC(Y,Z,MM,FL,MJ1)
C     Z=FL*Y
C     FL: LOWER TRIANGLE
C     Y: VECTOR
cxx      IMPLICIT REAL*8(A-H,O-Z)
cxx      DIMENSION Y(MM),Z(MM)
cc      DIMENSION FL(46,46)
cc      COMMON /COM25/FL
cxx      DIMENSION FL(MJ1,MJ1)
      INTEGER :: MM, MJ1
      REAL(8) :: Y(MM), Z(MM), FL(MJ1,MJ1)
      REAL(8) :: CST0, SUM
      CST0=0.0D-00
      DO 10 I=1,MM
      SUM=CST0
      DO 11 J=1,I
cxx   11 SUM=SUM+FL(I,J)*Y(J)
      SUM=SUM+FL(I,J)*Y(J)
   11 CONTINUE
      Z(I)=SUM
   10 CONTINUE
      RETURN
      END
C
cc      SUBROUTINE MWTFL(V,VV,MM)
      SUBROUTINE MWTFL(V,VV,MM,FL,MJ1)
C     VV=V'*FL
cxx      IMPLICIT REAL *8(A-H,O-Z)
cc      COMMON /COM20/V
cc      COMMON /COM21/VV
cc      COMMON /COM25/FL
cc      DIMENSION V(46,46),VV(46,46),FL(46,46)
cxx      DIMENSION V(MJ1,MJ1),VV(MJ1,MJ1),FL(MJ1,MJ1)
      INTEGER :: MM, MJ1
      REAL(8) :: V(MJ1,MJ1), VV(MJ1,MJ1), FL(MJ1,MJ1)
      REAL(8) :: CST0, SUM
      CST0=0.0D-00
      DO 10 I=1,MM
      DO 11 J=1,MM
      SUM=CST0
      DO 12 K=1,MM
cxx   12 SUM=SUM+V(K,I)*FL(K,J)
      SUM=SUM+V(K,I)*FL(K,J)
   12 CONTINUE
      VV(I,J)=SUM
   11 CONTINUE
   10 CONTINUE
      RETURN
      END
C
cc      SUBROUTINE NLTIV(R,RIN,DET,K,MJ)
      SUBROUTINE NLTIV(R,RIN,DET,K)
C     INVERSE OF R IS FACTORI
C     INVERSE OF R IS FACTORED INTO THE FORM L'*L IS
C     INVERSE OF R IS FACTORED INTO THE FORM L'*L. L,LOWER
C     INVERSE OF R IS FACTORED INTO THE FORM L'*L. L, LOWER TRIANGULAR,
C     IS RETURNED IN R. OTHER OUTPUTS ARE
C     RIN: INVERSE OF DIAGONAL L(I,J)
C     DET: DETERMINANT OF R(I,J)
C     MJ IS THE ABSOLUTE DIMENSION OF R IN THE MAIN ROUTINE
cxx      IMPLICIT REAL*8(A-H,O-Z)
cc      DIMENSION R(MJ,MJ),RIN(K)
cxx      DIMENSION R(K,K),RIN(K)
      INTEGER :: K
      REAL(8) :: R(K,K), RIN(K), DET
      REAL(8) :: CST0, CST1, ABC0, RR, RPIVOT, RIL
      CST0=0.0D-00
      CST1=1.0D-00
      KM1=K-1
      ABC0=CST0
      DET=CST1
      DO 10 L=1,K
      RR=R(L,L)
      DET=DET*RR
      RPIVOT=CST1/DSQRT(RR)
      R(L,L)=RPIVOT
      RIN(L)=CST1/RPIVOT
      DO 12 I=1,K
      IF(I.EQ.L) GO TO 12
      R(L,I)=RPIVOT*R(L,I)
   12 CONTINUE
      IF(L.EQ.K) GO TO 11
      L1=L+1
      DO 13 I=L1,K
      RIL=-RPIVOT*R(I,L)
      R(I,L)=RIL*RPIVOT
      DO 14 M=1,K
      IF(M.EQ.L) GO TO 14
      R(I,M)=R(I,M)+RIL*R(L,M)
   14 CONTINUE
   13 CONTINUE
   10 CONTINUE
   11 RETURN
      END
C
cc      SUBROUTINE NWFPEC(OSD,AO,L,IR,IL,N,IFPEC,MJ0,MJ)
      SUBROUTINE NWFPEC(AAIC,OAIC,CV,AST1,OSD,AO,AAO,L,IR,IL,N,IFPEC,
     *                  MJ0,LMAX2,LCV1)
C     AR-FITTING
C     AUTOREGRESSIVE MODEL FITTING BY THE MINIMUM AIC PROCEDURE.
cxx      IMPLICIT REAL*8(A-H,O-Z)
cc      DIMENSION CV(25,7,7)
cc      DIMENSION A1(13,7,7),B1(13,7,7)
cc      DIMENSION SD(7,7),SE(7,7),SF(7,7)
cc      DIMENSION XSD(7,7),XSF(7,7),D(7,7),E(7,7),Z1(7,7)
cc      DIMENSION SFL(7,7),RIN(7),B(7,7)
cc      DIMENSION AST1(91,7,7)
cc      DIMENSION OSD(7,7),AO(13,7,7)
cxx      DIMENSION CV(LCV1,IR+IL,IR+IL)
cxx      DIMENSION A1(L,IR+IL,IR+IL),B1(L,IR+IL,IR+IL)
cxx      DIMENSION SD(IR+IL,IR+IL),SE(IR+IL,IR+IL),SF(IR+IL,IR+IL)
cxx      DIMENSION XSD(IR+IL,IR+IL),XSF(IR+IL,IR+IL)
cxx      DIMENSION D(IR+IL,IR+IL),E(IR+IL,IR+IL),Z1(IR+IL,IR+IL)
cxx      DIMENSION SFL(IR+IL,IR+IL),RIN(IR+IL),B(IR+IL,IR+IL)
cxx      DIMENSION AST1(LMAX2,IR+IL,IR+IL)
cxx      DIMENSION OSD(IR,IR),AO(MJ0,IR,IR+IL),AAO(MJ0,IR,IR+IL)
cxx      DIMENSION AAIC(0:MJ0-1)
      INTEGER :: L, IR, IL, N, IFPEC, MJ0, LMAX2, LCV1
      REAL(8) :: AAIC(0:MJ0-1), OAIC, CV(LCV1,IR+IL,IR+IL),
     1           AST1(LMAX2,IR+IL,IR+IL), OSD(IR,IR),
     2           AO(MJ0,IR,IR+IL), AAO(MJ0,IR,IR+IL)
c
      REAL(8) :: A1(L,IR+IL,IR+IL), B1(L,IR+IL,IR+IL), SD(IR+IL,IR+IL),
     1           SE(IR+IL,IR+IL), SF(IR+IL,IR+IL), XSD(IR+IL,IR+IL),
     2           XSF(IR+IL,IR+IL), D(IR+IL,IR+IL), E(IR+IL,IR+IL),
     3           Z1(IR+IL,IR+IL), SFL(IR+IL,IR+IL), RIN(IR+IL),
     4           B(IR+IL,IR+IL), AIC, SFDT, SDDET, SFDET
cc      COMMON /COM9/AST1
cc      COMMON /COM10/CV
c
      IP=IR+IL
      L1=L+1
      CST0=0.0D-00
C     INITIAL CONDITION AND COVARIANCE PRINT OUT
C     INITIAL SD, SF, SE COMPUTATION
cxx      DO 330 II=1,IP
      DO 331 II=1,IP
      DO 330 JJ=1,IP
      SD(II,JJ)=CV(1,II,JJ)
      SF(II,JJ)=SD(II,JJ)
      SFL(II,JJ)=SF(II,JJ)
      SE(II,JJ)=CV(2,II,JJ)
      XSD(II,JJ)=SD(II,JJ)
cxx  330 XSF(II,JJ)=SF(II,JJ)
      XSF(II,JJ)=SF(II,JJ)
  330 CONTINUE
  331 CONTINUE
C     0-TH STEP COMPUTATION
      IFPEC=0
      MS=0
C     AIC COMPUTATION
cc      CALL SAIC (SD,N,IP,MS,AIC,MJ)
      CALL SAIC (SD,N,IP,MS,AIC)
      OAIC=AIC
C     AIC PRINT OUT
cc      WRITE(6,600)
cc      WRITE(6,264) MS,AIC
      AAIC(0)=AIC
cc      CALL NLTIV(SFL,RIN,SFDT,IP,MJ)
      CALL NLTIV(SFL,RIN,SFDT,IP)
C     SFL IS FACTORED INTO L'*L AND L IS RETURNED IN SFL
      INX=1
cxx      DO 8 II=1,IP
      DO 9 II=1,IP
      DO 8 JJ=1,II
      AST1(1,JJ,II)=CST0
cxx    8 AST1(1,II,JJ)=SFL(II,JJ)
      AST1(1,II,JJ)=SFL(II,JJ)
    8 CONTINUE
    9 CONTINUE
C     ITERATION M=1 TO L
      DO 400 M=1,L
C     INVERSE OF SD, SF COMPUTATION
C     COMMON SUBROUTINE CALL
cc      CALL INVDET(XSD,SDDET,IP,MJ)
      CALL INVDET(XSD,SDDET,IP,IP)
C     COMMON SUBROUTINE CALL
cc      CALL INVDET(XSF,SFDET,IP,MJ)
      CALL INVDET(XSF,SFDET,IP,IP)
C     D, E, SD, SF COMPUTATION
C     COMMON SUBROUTINE CALL
cc      CALL MULPLY(SE,XSF,D,IP,IP,IP,MJ,MJ,MJ)
      CALL MULPLY(SE,XSF,D,IP,IP,IP)
C     COMMON SUBROUTINE CALL
cc      CALL TRAMDL(SE,XSD,E,IP,IP,IP,MJ,MJ,MJ)
      CALL TRAMDL(SE,XSD,E,IP,IP,IP)
C     COMMON SUBROUTINE CALL
cc      CALL TRAMDR(D,SE,Z1,IP,IP,IP,MJ,MJ,MJ)
      CALL TRAMDR(D,SE,Z1,IP,IP,IP)
C     COMMON SUBROUTINE CALL
cc      CALL SUBTAL(SD,Z1,IP,IP,MJ,MJ)
      CALL SUBTAL(SD,Z1,IP,IP)
C     COMMON SUBROUTINE CALL
cc      CALL MULPLY(E,SE,Z1,IP,IP,IP,MJ,MJ,MJ)
      CALL MULPLY(E,SE,Z1,IP,IP,IP)
C     COMMON SUBROUTINE CALL
cc      CALL SUBTAL(SF,Z1,IP,IP,MJ,MJ)
      CALL SUBTAL(SF,Z1,IP,IP)
      MS=M
cxx      DO 410 II=1,IP
      DO 411 II=1,IP
      DO 410 JJ=1,IP
      XSD(II,JJ)=SD(II,JJ)
      XSF(II,JJ)=SF(II,JJ)
      SFL(II,JJ)=SF(II,JJ)
  410 CONTINUE
  411 CONTINUE
C     AIC COMPUTATION
cc     CALL SAIC (SD,N,IP,MS,AIC,MJ)
      CALL SAIC (SD,N,IP,MS,AIC)
C     AIC PRINT OUT
cc     WRITE(6,264) MS,AIC
      AAIC(MS) = AIC
cc      CALL NLTIV(SFL,RIN,SFDT,IP,MJ)
      CALL NLTIV(SFL,RIN,SFDT,IP)
C     SFL IS FACTORED INTO L'*L AND L IS RETURNED IN SFL
C     FORWARD AND BACKWARD PREDICTOR COMPUTATION
cc      CALL COEFAB(A1,B1,D,E,MS,IP,MJ0,MJ)
      CALL COEFAB(A1,B1,D,E,MS,L,IP)
      DO 14 I=1,M
      IMI=M+1-I
cxx      DO 15 II=1,IP
      DO 155 II=1,IP
      DO 15 JJ=1,IP
cxx   15 B(II,JJ)=B1(IMI,II,JJ)
      B(II,JJ)=B1(IMI,II,JJ)
   15 CONTINUE
  155 CONTINUE
cc      CALL BLMULP(SFL,B,Z1,IP,IP,MJ,MJ)
      CALL BLMULP(SFL,B,Z1,IP,IP)
      INX=INX+1
cxx      DO 16 II=1,IP
      DO 166 II=1,IP
      DO 16 JJ=1,IP
cxx   16 AST1(INX,II,JJ)=-Z1(II,JJ)
      AST1(INX,II,JJ)=-Z1(II,JJ)
   16 CONTINUE
  166 CONTINUE
   14 CONTINUE
      INX=INX+1
cxx      DO 17 II=1,IP
      DO 177 II=1,IP
      DO 17 JJ=1,II
      AST1(INX,JJ,II)=CST0
cxx   17 AST1(INX,II,JJ)=SFL(II,JJ)
      AST1(INX,II,JJ)=SFL(II,JJ)
   17 CONTINUE
  177 CONTINUE
C     MINIMUM AIC SEARCH
      IF(OAIC.LE.AIC) GO TO 440
      OAIC=AIC
      IFPEC=M
cxx      DO 560 II=1,IR
      DO 563 II=1,IR
      DO 560 JJ=1,IR
cxx  560 OSD(II,JJ)=SD(II,JJ)
      OSD(II,JJ)=SD(II,JJ)
  560 CONTINUE
  563 CONTINUE
      DO 561 I=1,M
cxx      DO 562 II=1,IR
      DO 564 II=1,IR
      DO 562 JJ=1,IP
      AAO(I,II,JJ)=-A1(I,II,JJ)
cxx  562 AO(I,II,JJ)=-A1(I,II,JJ)
      AO(I,II,JJ)=-A1(I,II,JJ)
  562 CONTINUE
  564 CONTINUE
  561 CONTINUE
  440 IF(M.EQ.L) GO TO 400
C     SE COMPUTATION
C     COMMON SUBROUTINE CALL
cc      CALL NEWSE(A1,SE,MS,IP,MJ0,MJ)
      CALL NEWSE(A1,CV,SE,MS,L,IP,LCV1)
  400 CONTINUE
C     MIN.AIC PRINT OUT
cc      WRITE(6,607) OAIC,IFPEC
C     OSD, AO PRINT OUT
cc      WRITE(6,608)
C     COMMON SUBROUTINE CALL
cc      CALL SUBMPR(OSD,IR,IR,MJ,MJ)
      IF(IFPEC.LE.0) GO TO 699
cc      WRITE(6,1601)
cc      WRITE(6,1602)
cc      WRITE(6,609)
C     COMMON SUBROUTINE CALL
cc      CALL PRMAT3(AO,IFPEC,IR,IP,0,MJ0,MJ,MJ)
      DO 1611 I=1,M
      DO 1612 II=1,IR
cxx      DO 1612 JJ=1,IP
      DO 1613 JJ=1,IP
cxx 1612 AO(I,II,JJ)=-AO(I,II,JJ)
      AO(I,II,JJ)=-AO(I,II,JJ)
 1613 CONTINUE
 1612 CONTINUE
 1611 CONTINUE
  699 RETURN
cxx    1 FORMAT(10I5)
cxx    2 FORMAT(4D20.10)
cxx   42 FORMAT(//1H ,17HCOVARIANCE MATRIX)
cxx  264 FORMAT(1H ,I5,2X,D16.7)
cxx  600 FORMAT(///1H ,4X,1HI,15X,3HAIC)
cxx  607 FORMAT(/1H ,'MINIMUM AIC ',D12.5,2X,'ATTAINED AT M=',I5)
cxx  608 FORMAT(//1H ,10X,10HOSD(II,JJ),': INNOVATION VARIANCE')
cxx  609 FORMAT(//1H ,10X,'A(I): AUTOREGRESSIVE COEFFICIENTS')
cxx 1601 FORMAT(/1H ,'AR-MODEL:')
cxx 1602 FORMAT(1H ,'Y(N)+A(1)Y(N-1)+...+A(L)Y(N-L)=X(N)')
      END
C
cc      SUBROUTINE SAIC (SD,N,K,MS,AIC,MJ)
      SUBROUTINE SAIC (SD,N,K,MS,AIC)
C     AIC COMPUTATION.
C     SD: COVARIANCE MATRIX OF INNOVATION
cxx      IMPLICIT REAL*8(A-H,O-Z)
cc      DIMENSION SD(MJ,MJ)
cc      DIMENSION SD1(7,7)
cxx      DIMENSION SD(K,K)
cxx      DIMENSION SD1(K,K)
      INTEGER :: N, K, MS
      REAL(8) :: SD(K,K), AIC
      REAL(8) :: SD1(K,K), AN, SDRM, ARM2
      AN=N
cxx      DO 9 I=1,K
      DO 10 I=1,K
      DO 9 J=1,K
cxx    9 SD1(I,J)=SD(I,J)
      SD1(I,J)=SD(I,J)
    9 CONTINUE
   10 CONTINUE
C     COMMON SUBROUTINE CALL
cc      CALL SUBDET(SD1,SDRM,K,MJ)
      CALL SUBDETC(SD1,SDRM,K)
      ARM2=2*MS*K*K
      AIC=AN*DLOG(SDRM)+ARM2
      RETURN
      END
C
cc      SUBROUTINE SBRUGT(MO,ID)
      SUBROUTINE SBRUGT(MO,ID,AST1,CV,RGT,MJ1,MJ,LMAX2,LCV1)
C     THIS SUBROUTINE COMPUTES MATRIX R12*G'.
C     INPUTS REQUIRED:
C     ID: DIMENSION OF Y(I) =IR=IP
C     MO: MAICE ORDER OF AR-MODEL
C     CV(I,II,JJ): COVARIANCE MATRIX
C     AST1(I,II,JJ): MATRIX G FOR ORTHO-NORMALIZATION OF THE PRESENT AND
C     PAST VARIABLES. G IS A LOWER TRIANGULAR BLOCK MATRIX WITH THE
C     STRUCTURE
C                  +-                            -+
C             G = I  L0	     0        0   ....  I
C                  I -L1B11  L1       0  .....  I
C                  I -L2B22 -L2B21 L2 ....  I
C                  I   .        .        ..      	...  I
C                  I   .        .        . .	..   I
C                  I   .        .        .  .	.    I
C                  I   .        .	   .   .       I
C                  I   .        .	   .    .      I
C                  I   .        .	   .     .     I
C                  I   .        .	   .      .    I
C                  +-			   -+
C     WHERE BMI'S ARE THE COEFFICIENTS OF THE M-TH ORDER BACKWARD AUTO-
C     REGRESSION,
C     Y(I-M)-BM1Y(I-M+1)-..-BMMY(I)=ZM(I-M)
C     AND LM(LM)'=INVERSE OF SD(M),WHERE SD(M) IS THE COVARIANCE MATRIX
C     RESIDUAL ZM(I).
C     OUTPUT:
C     RGT(I,J): MATRIX OF R12*G'
cxx      IMPLICIT REAL*8(A-H,O-Z)
cc      DIMENSION CV(25,7,7),AST1(91,7,7)
cc      DIMENSION RGT(91,91)
cc      DIMENSION X(7,7),Y(7,7)
cxx      DIMENSION CV(LCV1,ID,ID),AST1(LMAX2,MJ,MJ)
cxx      DIMENSION RGT(MJ1,MJ1)
cxx      DIMENSION X(ID,ID),Y(ID,ID)
      INTEGER :: MO, ID, MJ1, MJ, LMAX2, LCV1
      REAL(8) :: AST1(LMAX2,MJ,MJ), CV(LCV1,ID,ID), RGT(MJ1,MJ1)
      REAL(8) :: X(ID,ID), Y(ID,ID), CST0, SUM
c      COMMON /COM9/AST1
cc      COMMON /COM10/CV
cc      COMMON /COM11/RGT
      CST0=0.0D-00
      MP1=MO+1
cc      IRG=91
      IRG=MJ1
cxx      DO 9 I=1,IRG
cxx      DO 9 J=1,IRG
cxx      RGT(I,J)=CST0
cxx    9 CONTINUE
      RGT(1:IRG,1:IRG)=CST0
      INC=0
      DO 10 I=1,MP1
      IM1=I-1
      INX=0
      JNC=0
      DO 11 J=1,MP1
      DO 12 K=1,J
      IB=IM1+K
      JB=INX+K
      DO 18 II=1,ID
cxx      DO 18 JJ=1,ID
      DO 19 JJ=1,ID
      X(II,JJ)=CV(IB,II,JJ)
      Y(II,JJ)=AST1(JB,II,JJ)
   19 CONTINUE
   18 CONTINUE
      MJ7=7
      DO 15 II=1,ID
      DO 16 JJ=1,ID
      SUM=CST0
      DO 17 KK=1,ID
cxx   17 SUM=SUM+X(II,KK)*Y(JJ,KK)
      SUM=SUM+X(II,KK)*Y(JJ,KK)
   17 CONTINUE
      IN=INC+II
      JN=JNC+JJ
      RGT(IN,JN)=RGT(IN,JN)+SUM
   16 CONTINUE
   15 CONTINUE
   12 CONTINUE
      JNC=JNC+ID
      INX=INX+J
   11 CONTINUE
      INC=INC+ID
   10 CONTINUE
      RETURN
      END
C
cc      SUBROUTINE SUBBMA(AO,B,NH,M1,ID,IQ,MJ0,MJ)
      SUBROUTINE SUBBMA(AO,B,NH,M1,ID,IQ,MJ1,MJ0)
C     AR-FITTING
C     B-MATRIX COMPUTATION
C     (USE AR-COEFFICIENTS)
C     M1 IS LESS THAN 47.
cxx      IMPLICIT REAL*8(A-H,O-Z)
cc      DIMENSION AO(MJ0,MJ,MJ)
cc      DIMENSION X(13,7,7)
cc      DIMENSION XX(7,7),AA(7,7),C(7,7)
cc      DIMENSION W(100,7),B(46,7)
cc      DIMENSION NH(91)
cxx      DIMENSION AO(MJ0,ID,ID)
cxx      DIMENSION X(IQ,ID,ID)
cxx      DIMENSION XX(ID,ID),AA(ID,ID),C(ID,ID)
cxx      DIMENSION W(100,ID),B(MJ1,ID)
cxx      DIMENSION NH(M1)

      INTEGER :: NH(M1), M1, ID, IQ, MJ1, MJ0
      REAL(8) :: AO(MJ0,ID,ID), B(MJ1,ID)
      REAL(8) :: X(IQ,ID,ID), XX(ID,ID), AA(ID,ID), C(ID,ID), W(100,ID),
     1           CST0, CST1
      CST0=0.0D-00
      CST1=1.0D-00
      W(1:ID,1:ID)=CST0
      DO 10 I=1,ID
cxx      DO 11 J=1,ID
cxx   11 W(I,J)=CST0
cxx   10 W(I,I)=CST1
      W(I,I)=CST1
   10 CONTINUE
      IF(IQ.LE.1) GO TO 110
      MQ1=IQ-1
      DO 200 II=1,MQ1
cxx      DO 210 I=1,ID
      DO 211 I=1,ID
      DO 210 J=1,ID
cxx  210 X(II,I,J)=AO(II,I,J)
      X(II,I,J)=AO(II,I,J)
  210 CONTINUE
  211 CONTINUE
      IF(II.LE.1) GO TO 201
      IIM1=II-1
      DO 220 JJ=1,IIM1
cxx      DO 230 I=1,ID
      DO 231 I=1,ID
      DO 230 J=1,ID
cxx  230 AA(I,J)=AO(JJ,I,J)
      AA(I,J)=AO(JJ,I,J)
  230 CONTINUE
  231 CONTINUE
      IJ=II-JJ
cxx      DO 240 I=1,ID
      DO 241 I=1,ID
      DO 240 J=1,ID
cxx  240 XX(I,J)=X(IJ,I,J)
      XX(I,J)=X(IJ,I,J)
  240 CONTINUE
  241 CONTINUE
cc      CALL MULPLY(AA,XX,C,ID,ID,ID,MJ,MJ,MJ)
      CALL MULPLY(AA,XX,C,ID,ID,ID)
cxx      DO 250 I=1,ID
      DO 251 I=1,ID
      DO 250 J=1,ID
cxx  250 X(II,I,J)=X(II,I,J)+C(I,J)
      X(II,I,J)=X(II,I,J)+C(I,J)
  250 CONTINUE
  251 CONTINUE
  220 CONTINUE
cxx  201 DO 260 I=1,ID
  201 DO 261 I=1,ID
      DO 260 J=1,ID
      IC=ID+(II-1)*ID+I
cxx  260 W(IC,J)=X(II,I,J)
      W(IC,J)=X(II,I,J)
  260 CONTINUE
  261 CONTINUE
  200 CONTINUE
  110 DO 300 I=1,M1
      NHC=NH(I)
      DO 310 J=1,ID
cxx  310 B(I,J)=W(NHC,J)
      B(I,J)=W(NHC,J)
  310 CONTINUE
  300 CONTINUE
cxx  100 RETURN
      RETURN
      END
C
cc      SUBROUTINE VECMTX(X,Z,NH,MM,NN)
      SUBROUTINE VECMTX(X,Z,NH,RGT,MM,NN,MJ1)
C     Z=X*Y (X,Z: VECTORS, Y: SUBMATRIX)
cxx      IMPLICIT REAL*8(A-H,O-Z)
cxx      DIMENSION X(MM),Z(NN)
cc      DIMENSION RGT(91,91)
cc      DIMENSION NH(91)
cxx      DIMENSION RGT(MJ1,MJ1)
cxx      DIMENSION NH(MM)
      INTEGER :: NH(MM), MM, NN, MJ1
      REAL(8) :: X(MM), Z(NN), RGT(MJ1,MJ1)
      REAL(8) :: CST0, SUM
cc      COMMON /COM11/RGT
      CST0=0.0D-00
      DO 10 I=1,NN
      SUM=CST0
      DO 11 J=1,MM
      JJ=NH(J)
cxx   11 SUM=SUM+X(J)*RGT(JJ,I)
cxx   10 Z(I)=SUM
      SUM=SUM+X(J)*RGT(JJ,I)
   11 CONTINUE
      Z(I)=SUM
   10 CONTINUE
      RETURN
      END
C
cc      SUBROUTINE BLMULP(X,Y,Z,MM,NN,MJ1,MJ2)
      SUBROUTINE BLMULP(X,Y,Z,MM,NN)
C     COMMON SUBROUTINE
C     Z=X*Y (X: LOWER TRIANGLE)
cxx      IMPLICIT REAL*8(A-H,O-Z)
cc      DIMENSION X(MJ1,MJ1),Y(MJ1,MJ2),Z(MJ1,MJ2)
cxx      DIMENSION X(MM,MM),Y(MM,NN),Z(MM,NN)
      INTEGER :: MM, NN
      REAL(8) :: X(MM,MM), Y(MM,NN), Z(MM,NN)
      REAL(8) :: CST0, SUM
      CST0=0.0D-00
      DO 10 I=1,MM
      DO 11 J=1,NN
      SUM=CST0
      DO 12 K=1,I
cxx   12 SUM=SUM+X(I,K)*Y(K,J)
      SUM=SUM+X(I,K)*Y(K,J)
   12 CONTINUE
      Z(I,J)=SUM
   11 CONTINUE
   10 CONTINUE
      RETURN
      END
C
C
cc      SUBROUTINE SUBDET(X,XDETMI,MM,MJ)
      SUBROUTINE SUBDETC(X,XDETMI,MM)
C     COMMON SUBROUTINE
C     THIS SUBROUTINE COMPUTES THE DETERMINANT OF UPPER LEFT MM X MM
C     OF X.  FOR GENERAL USE STATEMENTS 20-21 SHOULD BE RESTORED.
C     X: ORIGINAL MATRIX
C     XDETMI: DETERMINANT OF UPPER LEFT MM X MM OF X
C     MJ: ABSOLUTE DIMENSION OF X IN THE MAIN ROUTINE
cxx      IMPLICIT REAL*8(X)
cc      DIMENSION X(MJ,MJ)
cxx      DIMENSION X(MM,MM)
      INTEGER :: MM
      REAL(8) :: X(MM,MM), XDETMI
      REAL(8) :: CST0, CST1, XC, XXC
      CST0=0.0D-00
      CST1=1.0D-00
      XDETMI=CST1
      IF(MM.EQ.1) GO TO 18
      MM1=MM-1
      DO 10 I=1,MM1
C   20 IF(X(I,I).NE.CST0) GO TO 11
C     DO 12 J=I,MM
C     IF(X(I,J).EQ.CST0) GO TO 12
C     JJ=J
C     GO TO 13
C  12 CONTINUE
C     XDETMI=CST0
C     GO TO 17
C  13 DO 14 K=I,MM
C     XXC=X(K,JJ)
C     X(K,JJ)=X(K,I)
C  14 X(K,I)=XXC
C  21 XDETMI=-XDETMI
cxx   11 XDETMI=XDETMI*X(I,I)
      XDETMI=XDETMI*X(I,I)
      XC=CST1/X(I,I)
      I1=I+1
      DO 15 J=I1,MM
      XXC=X(J,I)*XC
      DO 16 K=I1,MM
cxx   16 X(J,K)=X(J,K)-X(I,K)*XXC
      X(J,K)=X(J,K)-X(I,K)*XXC
   16 CONTINUE
   15 CONTINUE
   10 CONTINUE
   18 XDETMI=XDETMI*X(MM,MM)
cxx   17 RETURN
      RETURN
      END


!/*
! * One dimensional scattering - transmission coefficents
! */
!----------------------------main program declarations
       implicit real*8 (a-h, o-z)
real*8 pi,e0,v0,alpha,xint,x0,delx,tmax,delx2,dx,dk,dt,anorm,varg,s
!       parameter (hbar=1.d0, hbar2=1.d0, amass = 1.d0)
       parameter (pi = 3.141592653589793d0, Ndim=16384/2, s=1.25992104989)
       double precision x(Ndim),psi2(Ndim),psi(Ndim),psia2(ndim),vpot(ndim)
       complex*16 im,ExpT(Ndim),ExpV(Ndim),psiA(Ndim),ExpThalf(Ndim),ExpVhalf(Ndim),ExpTfull(Ndim),ExpVfull(Ndim)
!
       open (unit=13, file='win.pl')
       open (unit=14, file='wout.pl')
!-------------------------main program
       im = dcmplx(0.d0,1.d0)
	   m=12
	   e0=60.2d0
	   v0=48.2d0
!	   alpha=2.d0
	   alpha=1.0d0
	   xint=800.d0
	   x0=-100.d0
	   delx=25.d0
	   tmax=25.d0
	   iswitch=1
!
       N=2**m
       Nhalf = N/2
       delx2 = delx*delx
!
!  Decide the grid sizes, and the time step in seconds.
!
       dx = xint/dble(N)
       dk = 2.d0*pi/xint
!  Save the x-grids and initialize the wavefunction:
!  x ranges from -N/2*dx to N/2*dx.
!
       Do i = 1, N
        x(i) = dx*(i-Nhalf)
       END DO
!

   do 200 iv=1,1
   dt=0.05+(iv-1)*.01d0
!       dt = 0.1
       limit = int(tmax/dt+0.1)
!
     anorm = 1.d0/dsqrt(delx*dsqrt(2.d0*pi))
     ak0 = dsqrt(2.d0*E0)
       Do i = 1, N
        psiA(i) = anorm*cdexp(im*ak0*x(i)-(x(i)-x0)**2/(4.d0*delx2))
!        psiA(i)=psi(i)
       END DO
       y = pi*ak0/alpha
       anum = (dsinh(y))**2
       ay0 = 8.d0*V0/(alpha*alpha)
       if (ay0.le.(1.d0)) then
        y0 = pi*dsqrt(1.d0 - ay0)/2.d0
        deno = 1.d0 + (dcos(y0))**2/anum
       else
        y0 = pi*dsqrt(ay0 - 1.d0)/2.d0
        deno = 1.d0 + (dcosh(y0))**2/anum
       end if
        TC = 1.d0/deno
!       write(14,46) TC
  46   format(/' theoretical transmission coefficient=', f10.6)
  99   format(16400(f10.6))
!  Initialize the arrays ExpT and ExpV,
!
!  ExpT is an array of values exp(-i T(k) dt), where T(k)=E.
!
       DO i = 1, Nhalf
!
! For k's between 0 and the Nyquist cutoff:
!
          ak  = dble(i-1) * dk
          E  = ak*ak/2.d0
          ExpT(i) = cdexp( -im * E * dt)
          ExpThalf(i) = cdexp( -im * E * dt / (2.d0-s))
          ExpTfull(i) = cdexp( im * E * dt * s / (2.d0-s))
!
! K's above the Nyquist cutoff are actually negative:
!
          ak  = -dble(i) * dk
          E  = ak * ak / 2.d0
          ExpT(N+1-i) = cdexp( -im * E * dt )
          ExpThalf(N+1-i) = cdexp( -im * E * dt / (2.d0-s))
          ExpTfull(N+1-i) = cdexp( im * E * dt * s / (2.d0-s))
       END DO
!
!  ExpV is an array of values exp(-i V dt / 2)
!
       DO i = 1, N
	  varg=alpha*x(i)
	   If (dabs(varg).gt.100) then
	     v=0.0
	   else
           V = V0 / (dcosh(alpha*x(i)))**2
	   end if
	   vpot(i)=v
        ExpV(i) = cdexp( -im * V * dt / 2.d0 )
        ExpVhalf(i) = cdexp( -im * V * dt / (2*(2.d0-s)))
        ExpVfull(i) = cdexp( im * V * dt * s / (2*(2.d0-s)))
       END DO
!
!  Loop over propagation steps until time > MaxTime:
!
        evotime = 0.d0
       Do 100 j = 1, limit
!        evotime = evotime + dt
!      call schem2A(m,N,ExpT,ExpV,psiA)
      call schem4A(m,N,ExpT,ExpV,psiA,ExpThalf,ExpVhalf,ExpTfull,ExpVfull)

!write to terminal, if iswitch = 0 will print result at all time steps, if iswitch = 1, only prints final result
 if(iswitch.eq.0) then
     if( mod(j,20).eq.0 ) then
       sumR=0.d0
       sumT=0.d0

       DO i = 1, Nhalf

        sumR = sumR + cdabs(psiA(i))**2
        sumT = sumT + cdabs(psiA(N+1-i))**2

	   end do
	   write(*,99) j*dt,dt,sumt/(sumt+sumr),tc, psiA
	   !write(14,99) j*dt,dt,sumt/(sumt+sumr),tc, psiA
     end if
 end if
 100   continue
   if( iswitch.eq.1 ) then
       sumR=0.d0
       sumT=0.d0
       DO i = 1, Nhalf
        sumR = sumR + cdabs(psiA(i))**2
        sumT = sumT + cdabs(psiA(N+1-i))**2
	   end do
!	   write(*,99) j*dt,dt,sumt/(sumt+sumr),(sumt+sumr)*dx
	   write(*,99) e0, sumt+sumr,sumt,sumt/(sumt+sumr),tc
	   write(14,99) e0, sumt+sumr,sumt,sumt/(sumt+sumr),tc
   end if
 200 continue
end

!-----------subprograms----------------------------------------------------
       Subroutine schem2A(m,N,ExpTA,ExpVA,psi)
!
!   To calculate the 2nd-order decomposition scheme.
!
       parameter (Ndim=16384/2)
       complex*16 ExpTA(1),ExpVA(1),psi(1),phi(Ndim)
!
        DO i = 1, N
          phi(i) = ExpVA(i) * psi(i)
        END DO
        call fft (phi, m, 0)
        DO i = 1, N
          phi(i) = ExpTA(i) * phi(i)
        END DO
        call fft (phi, m, 1 )
        DO i = 1, N
          psi(i) = ExpVA(i) * phi(i)
        END DO
!*
       return
       end
!*

!-----------subprograms----------------------------------------------------
       Subroutine schem4A(m,N,ExpTA,ExpVA,psi,ExpThalfA,ExpVhalfA,ExpTfullA,ExpVfullA)
!
!   To calculate the 4th-order decomposition scheme.
!
       parameter (Ndim=16384/2)
       complex*16 ExpTA(1),ExpVA(1),psi(1),ExpThalfA(1),ExpVhalfA(1),ExpTfullA(1),ExpVfullA(1),phi(Ndim)
!
        DO i = 1, N
          phi(i) = ExpVhalfA(i) * psi(i)
        END DO
        call fft (phi, m, 0)
        DO i = 1, N
          phi(i) = ExpThalfA(i) * phi(i)
        END DO
        call fft (phi, m, 1 )
        DO i = 1, N
          psi(i) = ExpVhalfA(i) * phi(i)
        END DO
        DO i = 1, N
          phi(i) = ExpVfullA(i) * psi(i)
        END DO
        call fft (phi, m, 0)
        DO i = 1, N
          phi(i) = ExpTfullA(i) * phi(i)
        END DO
        call fft (phi, m, 1 )
        DO i = 1, N
          psi(i) = ExpVfullA(i) * phi(i)
        END DO
        DO i = 1, N
          phi(i) = ExpVhalfA(i) * psi(i)
        END DO
        call fft (phi, m, 0)
        DO i = 1, N
          phi(i) = ExpThalfA(i) * phi(i)
        END DO
        call fft (phi, m, 1 )
        DO i = 1, N
          psi(i) = ExpVhalfA(i) * phi(i)
        END DO
!*
       return
       end
!*

!*******************************************************************
!
      Subroutine FFT(A,m,INV)
!*------------------------------------------------------------------*
!*                                                                  *
!* A First Course in Computational Physics                          *
!*                                                                  *
!* Paul L. DeVries, Department of Physics, Miami University         *
!*                                                                  *
!* This subroutine performs the Fast Fourier Transform by           *
!* the method of Cooley and Tukey --- the FORTRAN code was          *
!* adapted from                                                     *
!*                                                                  *
!*   Cooley, Lewis, and Welch, IEEE Transactions E-12               *
!*       (March 1965).                                              *
!*                                                                  *
!* The array A contains the complex data to be transformed,         *
!* `m' is log2(N), and INV is an index = 1 if the inverse           *
!* transform is to be computed. (The forward transform is           *
!* evaluated if INV is not = 1.)                                    *
!*                                                                  *
!*                            start: 1965                           *
!*                    last modified: 1993                           *
!*                                                                  *
!------------------------------------------------------------------*
!*
       Complex*16 A(1), u, w, t
       Double precision ang, pi
       Integer N, Nd2, i, j, k, l, le, le1, ip
       Parameter (pi = 3.141592653589793d0)
!
!*  This routine computes the Fast Fourier Transform of the
!*  input data and returns it in the same array. Note that
!*  the k's and x's are related in the following way:
!*
!*    IF    K = range of k's      and     X = range of x's
!*
!*    THEN  delta-k = 2 pi / X    and   delta-x = 2 pi / K
!*
!*  When the transform is evaluated, it is assumed that the
!*  input data is periodic. The output is therefore periodic
!*  (you have no choice in this). Thus, the transform is
!*  periodic in k-space, with the first N/2 points being
!*  'most significant'. The second N/2 points are the same
!*  as the Fourier transform at negative k!!! That is,
!*
!*              FFT(N+1-i) = FFT(-i)  ,i = 1,2,....,N/2
!*
       N   = 2**m
       Nd2 = N/2
       j   = 1
       DO i = 1, N-1
          IF( i .lt. j ) THEN
             t    = A(j)
             A(j) = A(i)
             A(i) = t
          ENDIF
          k = Nd2
100       IF( k .lt. j ) THEN
             j = j-k
             k = k/2
             goto 100
          ENDIF
          j  = j+k
       END DO
       le = 1
       DO l = 1, m
          le1 = le
          le  = le + le

          u = ( 1.D0, 0.D0 )
          ang = pi / dble(le1)
          W = Dcmplx( cos(ang), -sin(ang) )
          IF(inv .eq. 1) W = Dconjg(W)

          DO j = 1, le1
             DO i = j, N, le
                ip   = i+le1
                t    = A(ip)*u
                A(ip)= A(i)-t
                A(i) = A(i)+t
             END DO
             u=u*w
          END DO

       END DO

!c       IF(inv .ne. 1) THEN
       IF(inv .eq. 1) THEN
          DO i = 1, N
             A(i) = A(i) / dble(N)
          END DO
       ENDIF
	   return
       end