      SUBROUTINE  EXSARF( Z1,N,LAG,ZMEAN,SUM,SD,AIC,DIC,M1,AMIN,SDM1,A1,
cx     *                    SDM2,A2,TMP,IER,JER )
     *                    SDM2,A2,JER )
c----------------   for  isw = 2   --------------------
cxc     *                    SDM22,A22,TMP )
c     *                    SDM22,A22,JER )
C
      INCLUDE 'timsac_f.h'
C
cc      PROGRAM  EXSAR
C.......................................................................
C.....PLANNED BY H.AKAIKE...............................................
C.....DESIGNED BY H.AKAIKE AND G.KITAGAWA...............................
C.....PROGRAMMED BY G.KITAGAWA AND F.TADA...............................
C.....ADDRESS: THE INSTITUTE OF STATISTICAL MATHEMATICS, 4-6-7 MINAMI-AZ
C..............MINATO-KU, TOKYO 106, JAPAN..............................
C.....DATE OF THE LATEST REVISION:  JUN. 29, 1979.......................
C.......................................................................
C.....THIS PROGRAM WAS ORIGINALLY PUBLISHED IN "TIMSAC-78", BY H.AKAIKE,
C.....G.KITAGAWA, E.ARAHATA AND F.TADA, COMPUTER SCIENCE MONOGRAPHS, NO.
C.....THE INSTITUTE OF STATISTICAL MATHEMATICS, TOKYO, 1979.............
C.......................................................................
C     TIMSAC 78.5.1
C     __                                 _      __
C     EXACT MAXIMUM LIKELIHOOD METHOD OF SCALAR AR-MODEL FITTING
C
C     THIS PROGRAM PRODUCES EXACT MAXIMUM LIKELIHOOD ESTIMATES OF THE
C     PARAMETERS OF A SCALAR AR-MODEL.
C
C     THE AR-MODEL IS GIVEN BY
C
C               Z(I) = A(1)*Z(I-1) + ... + A(K)*Z(I-K) + E(I)
C
C     WHERE E(I) IS A ZERO MEAN WHITE NOISE.
C
C     --------------------------------------------------------------
C     THE FOLLOWING SUBROUTINES ARE DIRECTLY CALLED BY THIS PROGRAM:
C             REDATA
C             REDUCT
C             ARMFIT
C             RECOEF
C             ARMLE
C             PRINTA
C     --------------------------------------------------------------
C     INPUTS REQUIRED:
C          MT:      INPUT DEVICE SPECIFICATION (MT=5: CARD READER)
C          LAG:     UPPER LIMIT OF AR-ORDER, MUST BE LESS THAN 51
C
C     --  THE FOLLOWING INPUTS ARE REQUESTED BY SUBROUTINE REDATA  --
C          TITLE:  TITLE OF DATA
C          N:      DATA LENGTH, MUST BE LESS THAN OR EQUAL TO 10000
C          DFORM:  INPUT DATA FORMAT SPECIFICATION STATEMENT
C                  -- EXAMPLE --     (8F10.5)
C          (Z(I),I=1,N):  ORIGINAL DATA
C     ---------------------------------------------------------------
C
cc      !DEC$ ATTRIBUTES DLLEXPORT :: EXSARF
C
cxx      IMPLICIT  REAL *8  ( A-H , O-Z )
CC      REAL * 4  Z(10000) , TITLE(20)
cc      REAL * 4   TITLE(20)
cc      DIMENSION  Z(10000)
cc      DIMENSION  X(200,51) , D(200) , A(50)
cxx      DIMENSION  Z1(N), Z(N)
cxx      DIMENSION  X(N-LAG,LAG+1), A1(LAG), A2(LAG)
c----------------    isw = 2   -----------------
cxx      DIMENSION  A22(LAG,LAG), SDM22(LAG)
c-----------------------------------------------

      INTEGER :: N, LAG, M1, JER
      REAL(8) :: Z1(N), ZMEAN, SUM, SD(LAG+1), AIC(LAG+1), DIC(LAG+1),
     1           AMIN, SDM1, A1(LAG), SDM2, A2(LAG)
      REAL(8) :: Z(N), X(N-LAG,LAG+1)
c----------------    isw = 2   -----------------
      REAL(8) :: A22(LAG,LAG), SDM22(LAG)
c-----------------------------------------------

CC      COMMON     / AAA /  N , Z
cc      COMMON     / AAA /  N
cc      COMMON     / BBB /  Z
cc      COMMON     / CCC /  ISW , IPR
C
cxx      DIMENSION  SD(LAG+1), AIC(LAG+1), DIC(LAG+1)
cx      INTEGER*1  TMP(1)
cx      CHARACTER  CNAME*80
C
cc      CHARACTER(100) IFLNAM,OFLNAM
C
C       EXTERNAL SUBROUTINE DECLARATION:
C
      EXTERNAL   SETX1
C
cc      CALL FLNAM2( IFLNAM,OFLNAM,NFL )
cc      IF ( NFL.EQ.0 ) GO TO 999
cc      IF ( NFL.EQ.2 ) THEN
cc         OPEN( 6,FILE=OFLNAM,ERR=900,IOSTAT=IVAR )
cc      ELSE
cc         CALL SETWND
cc      END IF
cx      IER=0
cx      LU=3
cx      DO 100 I = 1,80
cx         CNAME(I:I) = ' '
cx  100 CONTINUE
cx      I = 1
cx      IFG = 1
cx      DO WHILE( (IFG.EQ.1) .AND. (I.LE.80) )
cx	   IF ( TMP(I).NE.ICHAR(' ') ) THEN
cx            CNAME(I:I) = CHAR(TMP(I))
cx            I = I+1
cx         ELSE
cx            IFG = 0
cx         END IF
cx      END DO
cx      IF ( I.GT.1 ) THEN
cx         IFG = 1
cx         OPEN (LU,FILE=CNAME,IOSTAT=IVAR)
cx         IF (IVAR .NE. 0) THEN
cxcx            WRITE(*,*) ' ***  exsar temp FILE OPEN ERROR :',CNAME,IVAR
cx            IER=IVAR
cx            IFG=0
cx         END IF
cx      END IF
C
C          PARAMETERS:
C             MJ1:  ABSOLUTE DIMENSION FOR SUBROUTINE CALL
C             ISW:  =1  PARAMETERS OF MAICE MODEL ONLY ARE REQUESTED
C                   =2  PARAMETERS OF ALL MODELS ARE REQUESTED
C             IPR:  PRINT OUT CONTROL IN THE NON-LINEAR OPTIMIZATION PRO
C
cc      MJ1 = 200
      MJ1 = N-LAG
      ISW = 1
C
CC      READ( 5,1 )     MT
cc      MT = 5
cc      OPEN( MT,FILE=IFLNAM,ERR=910,IOSTAT=IVAR,STATUS='OLD')
cc      READ( 5,1 )     LAG
cc      WRITE( 6,2 )
cc      WRITE( 6,3 )   LAG , MT
C
C          +-----------------------------------------+
C          ! ORIGINAL DATA LOADING AND MEAN DELETION !
C          +-----------------------------------------+
C
cc      CALL  REDATA( Z,N,MT,TITLE )
cc      CLOSE( MT )
      CALL  REDATA( Z1,Z,N,ZMEAN,SUM )
      K = LAG
      NMK = N - K
C
C          +-----------------------+
C          ! HOUSEHOLDER REDUCTION !
C          +-----------------------+
C
cc      CALL  REDUCT( SETX1,Z,D,NMK,0,K,MJ1,LAG,X )
      CALL  REDUCT( SETX1,Z,NMK,0,K,MJ1,LAG,X )
C
C          +------------------+
C          ! AR MODEL FITTING !
C          +------------------+
C
cc      CALL  ARMFIT( X,K,LAG,NMK,ISW,TITLE,MJ1,A,SD,M )
cx      CALL  ARMFIT( X,K,LAG,NMK,ISW,MJ1,A1,M1,SD,AIC,DIC,SDM1,AMIN,
cx     *              IFG,LU )
      CALL  ARMFIT( X,K,LAG,NMK,ISW,MJ1,A1,M1,SD,AIC,DIC,SDM1,AMIN )
      DO 5  I = 1,K
cxx    5 A2(I) = A1(I)
      A2(I) = A1(I)
    5 CONTINUE
C
C          +-------------------------------------------+
C          ! MAXIMIZATION OF EXACT LIKELIHOOD FUNCTION !
C          +-------------------------------------------+
C
      JER = 0
      IF( ISW .EQ. 2 )  GO TO 10
C
      IPR = 7
cc      CALL  ARMLE( Z,N,M,K,TITLE,A )
ccx      CALL  ARMLE( Z,N,M1,K,A2,SDM2,ISW,IPR,IFG,LU )
cx      CALL  ARMLE( Z,N,M1,K,A2,SDM2,ISW,IPR,IFG,LU,JER )
cxx      CALL  ARMLE( Z,N,M1,K,A2,SDM2,ISW,IPR,JER )
      CALL  ARMLE( Z,N,M1,K,A2,SDM2,ISW,JER )
cx      IF( JER .NE. 0 ) RETURN
cx      IF (IFG.NE.0) CLOSE(LU)
      RETURN
C
   10 DO 20  M=1,K
cc      CALL  RECOEF( X,M,K,MJ1,A )
      CALL  RECOEF( X,M,K,MJ1,A2 )
      IPR = 5
cc   20 CALL  ARMLE( Z,N,M,K,TITLE,A )
ccx      CALL  ARMLE( Z,N,M,K,A2,SDM2,ISW,IPR,IFG,LU )
cx      CALL  ARMLE( Z,N,M,K,A2,SDM2,ISW,IPR,IFG,LU,JER )
cxx      CALL  ARMLE( Z,N,M,K,A2,SDM2,ISW,IPR,JER )
      CALL  ARMLE( Z,N,M,K,A2,SDM2,ISW,JER )
      IF( JER .NE. 0 ) RETURN
      DO 15  I = 1,M
cxx   15 A22(I,M) = A2(I)
      A22(I,M) = A2(I)
   15 CONTINUE
      SDM22(M) = SDM2
   20 CONTINUE
cc      GO TO 999
C
cc  900 CONTINUE
cc      WRITE(6,600) IVAR,OFLNAM
cc  600 FORMAT(/,' !!! Output_Data_File OPEN ERROR ',I8,//,5X,100A)
cc      GO TO 999
C
cc  910 CONTINUE
cc      IF ( NFL.EQ.2 ) CLOSE( 6 )
cc#ifdef __linux__
ccC     reopen #6 as stdout
cc      IF ( NFL.EQ.2 ) OPEN(6, FILE='/dev/fd/1')
cc#endif
ccC /* __linux__ */
cc      WRITE(6,610) IVAR,IFLNAM
cc  610 FORMAT(/,' !!! Input_Data_File OPEN ERROR ',I8,//,5X,100A)
C
cxx    1 FORMAT( 16I5 )
cxx    2 FORMAT( 1H ,'PROGRAM 78.5.1',/,'   EXACT MAXIMUM LIKELIHOOD METHOD
cxx     * OF AUTOREGRESSIVE MODEL FITTING;  SCALAR CASE',/,'   < BASIC AUTO
cxx     *REGRESSIVE MODEL >',/,1H ,10X, 'Z(I) = A(1)*Z(I-1) + ... + A(K)*Z(
cxx     *I-K) + E(I)',/,1H ,'WHERE',/,11X,'K:     ORDER OF THE MODEL',/,11X
cxx     *,'E(I):  ZERO MEAN WHITE NOISE' )
cxx    3 FORMAT( ///1H ,'  FITTING UP TO THE ORDER  K =',I3,'  IS TRIED',/,
cxx     *1H ,'  ORIGINAL DATA INPUT DEVICE  MT =',I3 )
C
cc  999 CONTINUE
cx      IF (IFG.NE.0) CLOSE(LU)
      RETURN
      E N D
cc      SUBROUTINE  ARMLE( Z,N,K,L,TITLE,A )
ccx      SUBROUTINE  ARMLE( Z,N,K,L,A,SDM,ISW,IPR,IFG,LU )
cx      SUBROUTINE  ARMLE( Z,N,K,L,A,SDM,ISW,IPR,IFG,LU,JER )
cxx      SUBROUTINE  ARMLE( Z,N,K,L,A,SDM,ISW,IPR,JER )
      SUBROUTINE  ARMLE( Z,N,K,L,A,SDM,ISW,JER )
C.....DATE OF THE LATEST REVISION:  JUN. 29, 1979.......................
C
C     THIS SUBROUTINE PRODUCES EXACT MAXIMUM LIKELIHOOD ESTIMATES OF THE
C     PARAMETERS OF AN AUTOREGRESSIVE MODEL
C
C       ----------------------------------------------------------------
C       THE FOLLOWING SUBROUTINES ARE DIRECTLY CALLED BY THIS SUBROUTINE
C             DAVIDN
C             PRINTA
C       ----------------------------------------------------------------
C          INPUTS:
C             Z:       ORIGINAL DATA
C             N:       DATA LENGTH
C             K:       ORDER OF THE AR-MODEL
C             L:       HIGHEST POSSIBLE ORDER OF THE MODEL
C             TITLE:   TITLE OF DATA
C
C          OUTPUTS:
C             A:       MAXIMUM LIKELIHOOD ESTIMATES OF AR-COEFFICIENTS
C
C
cxx      IMPLICIT  REAL * 8  ( A-H , O-Z )
CC      REAL * 4   Z , TITLE
cc      REAL * 4   TITLE
cc      DIMENSION  Z(1) , A(1) , TITLE(1)
cc      DIMENSION  R(31,31) , C(31)
cxx      DIMENSION  Z(N), A(K)
cxx      DIMENSION  R(K+1,K+1), C(L+1)
      INTEGER :: N, K, L, ISW, JER
      REAL(8) :: Z(N), A(K), SDM
      REAL(8) :: R(K+1,K+1), C(L+1), SUM, F0, AIC, SD
CC      DIMENSION  TTL(4)
cc      REAL * 4 TTL(8)
cc      COMMON     / DDD /  R , F , AIC , SD
CC      DATA         TTL / 8H  MAXIMU,8HM LIKELI,8HHOOD EST,8HIMATE  . /
cc      DATA         TTL / 4H  MA,4HXIMU,4HM LI,4HKELI,
cc     1					4HHOOD,4H EST,4HIMAT,4HE  . /
C
C       EXTERNAL FUNCTION DECRALATION
C
      EXTERNAL  FUNCT
      EXTERNAL  HESIAN
C
      IHES = 1
C
cc      WRITE( 6,3 )
cx      IF( IFG.NE.0 ) WRITE( LU,3 )  K
      NMLP1 = N - L + 1
      K1 = K + 1
      L1 = L + 1
      N1 = N + 1
      NML = N - L
      DO  20  II=1,L1
      J = II - 1
      SUM = 0.D0
      DO 10  I=L1,NML
      IMJ = I - J
cxx   10 SUM = SUM + Z(I)*Z(IMJ)
      SUM = SUM + Z(I)*Z(IMJ)
   10 CONTINUE
cxx   20 C(II) = SUM
      C(II) = SUM
   20 CONTINUE
C
C       COVARIANCE MATRIX R COMPUTATION
C
cxx      DO 70  II=1,K1
      DO 71  II=1,K1
      KMI = K1 - II + 1
      NMI = N1 - II
      DO 70  JJ=II,K1
      JMI = JJ - II
      SUM = C(JMI+1)
      IF( KMI .GT. L )  GO TO 40
      DO 30  KK=KMI,L
      KI = KK - JMI
cxx   30 SUM = SUM + Z(KK)*Z(KI)
      SUM = SUM + Z(KK)*Z(KI)
   30 CONTINUE
   40 CONTINUE
      IF( NMLP1 .GT. NMI )  GO TO 60
      DO 50  KK=NMLP1,NMI
      KI = KK - JMI
cxx   50 SUM = SUM + Z(KK)*Z(KI)
      SUM = SUM + Z(KK)*Z(KI)
   50 CONTINUE
   60 R(II,JJ) = SUM
      R(JJ,II) = SUM
   70 CONTINUE
   71 CONTINUE
C
C       DAVIDON'S MINIMIZATION PROCEDURE
C
      F0 = 1.0D60
      DO  80   I=1,5
C
cc      CALL  DAVIDN( FUNCT,HESIAN,A,K,IHES )
ccx      CALL  DAVIDN( FUNCT,HESIAN,Z,N,A,K,R,IHES,ISW,IPR,AIC,SD,IFG,LU )
cx      CALL  DAVIDN( FUNCT,HESIAN,Z,N,A,K,R,IHES,ISW,IPR,AIC,SD,
cx     *                     IFG,LU,JER )
cxx      CALL  DAVIDN( FUNCT,HESIAN,Z,N,A,K,R,IHES,ISW,IPR,AIC,SD,JER )
      CALL  DAVIDN( FUNCT,HESIAN,Z,N,A,K,R,IHES,ISW,AIC,SD,JER )
      IF( JER .NE. 0 ) RETURN
C
      IF( F0-AIC .LT. 0.001 )     GO TO 90
cxx   80 F0 = AIC
      F0 = AIC
   80 CONTINUE
   90 CONTINUE
C
cc      CALL  PRINTA( A,SD,K,TTL,8,TITLE,1,N )
      SDM = SD
C
      RETURN
cc    3 FORMAT( //1H ,29(1H-),/,' EXACT LIKELIHOOD MAXIMIZATION',/,1H ,29(
cc     11H-) )
cxx    3 FORMAT( //1H ,29(1H-),/,' EXACT LIKELIHOOD MAXIMIZATION',10x,
cxx     *'ORDER OF THE AR-MODEL =',i5,/1H ,29(1H-) )
cxx   65 FORMAT( 1H ,10D13.5 )
      END
cc      SUBROUTINE  DAVIDN( FUNCT,HESIAN,X,N,IHES )
cxx      SUBROUTINE  DAVIDN( FUNCT,HESIAN,Z,NZ,X,N,R,IHES,ISW,IPR,AIC,SD,
ccx     *                    IFG,LU )
cx     *                    IFG,LU,JER )
cxx     *                    JER )
      SUBROUTINE  DAVIDN( FUNCT,HESIAN,Z,NZ,X,N,R,IHES,ISW,AIC,SD,JER )
C.....DATE OF THE LATEST REVISION:  JUN. 29, 1979.......................
C
C          MINIMIZATION BY DAVIDON-FLETCHER-POWELL PROCEDURE
C
C       ----------------------------------------------------------------
C       THE FOLLOWING SUBROUTINES ARE DIRECTLY CALLED BY THIS SUBROUTINE
C             FUNCT
C             HESIAN
C             LINEAR
C       ----------------------------------------------------------------
C          INPUTS:
C             FUNCT:   EXTERNAL FUNCTION SPECIFICATION
C             HESIAN:  EXTERNAL FUNCTION SPECIFICATION
C             X:       VECTOR OF INITIAL VALUES
C             N:       DIMENSION OF THE VECTOR X
C             IHES:    =0   INVERSE OF HESSIAN MATRIX IS NOT AVAILABLE
C                      =1   INVERSE OF HESSIAN MATRIX IS AVAILABLE
C
C          OUTPUT:
C             X:       VECTOR OF MINIMIZING SOLUTION
C
cxx      IMPLICIT  REAL * 8  ( A-H , O-Z )
cc      DIMENSION  X(50) , DX(50) , G(50) , G0(50) , Y(50)
cc      DIMENSION  H(50,50) , WRK(50) , S(50)
cc      DIMENSION  R(31,31)
cxx      DIMENSION  Z(NZ)
cxx      DIMENSION  X(N) , DX(N) , G(N) , G0(N) , Y(N)
cxx      DIMENSION  H(N,N) , WRK(N) , S(N)
cxx      DIMENSION  R(N+1,N+1)
      INTEGER :: NZ, N, IHES, ISW, JER
      REAL(8) :: Z(NZ), X(N), R(N+1,N+1), AIC, SD
      REAL(8) :: DX(N), G(N), G0(N), Y(N), H(N,N), WRK(N), S(N),
     1           TAU1, TAU2, EPS1, EPS2, RAMDA, CONST1, SUM,
     2           S1, S2, STEM, SS, DS2, GTEM, ED, F, XM, XMB
C
cc      COMMON     / CCC /  ISW, IPR
cc      COMMON     / DDD /  R , F , AIC , SD
      DATA  TAU1 , TAU2  /  1.0D-5 , 1.0D-5  /
      DATA  EPS1 , EPS2  / 1.0D-5 , 1.0D-5  /
      EXTERNAL  FUNCT
C
      RAMDA = 0.5D0
      CONST1 = 1.0D-70
C
C          INITIAL ESTIMATE OF INVERSE OF HESSIAN
C
      H(1:N,1:N) = 0.0D00
      S(1:N) = 0.0D00
      DX(1:N) = 0.0D00
      DO  20   I=1,N
cxx      DO  10   J=1,N
cxx   10 H(I,J) = 0.0D00
cxx      S(I) = 0.0D00
cxx      DX(I) = 0.0D00
cxx   20 H(I,I) = 1.0D00
      H(I,I) = 1.0D00
   20 CONTINUE
      ISW = 0
C
cc      CALL  FUNCT( N,X,XM,G,IG )
cx      CALL  FUNCT( Z,NZ,N,X,R,ISW,XM,G,AIC,SD,F,IG )
      CALL  FUNCT( Z,NZ,N,X,R,ISW,XM,G,AIC,SD,F,IG,JER )
      IF( JER .NE. 0 ) RETURN
C
cc      IF( IPR .GE. 2 )   WRITE( 6,340 )   XM, SD, AIC
cx      IF( (IPR.GE.2) .AND. (IFG.NE.0) )  WRITE( LU,340 )  XM, SD, AIC
C
C          INVERSE OF HESSIAN COMPUTATION (IF AVAILABLE)
C
cc      IF( IHES .EQ. 1 )   CALL  HESIAN( X,N,H )
      IF( IHES .EQ. 1 )   CALL  HESIAN( X,N,NZ,R,SD,H )
C
      ICC = 0
C      ITERATION
11110 CONTINUE
      ICC = ICC + 1
      DO  11111   IC=1,N
      IF( IC .EQ. 1 .AND. ICC .EQ. 1 )     GO TO 120
C
      DO  40   I=1,N
cxx   40 Y(I) = G(I) - G0(I)
      Y(I) = G(I) - G0(I)
   40 CONTINUE
      DO  60   I=1,N
      SUM = 0.0D00
      DO  50   J=1,N
cxx   50 SUM = SUM + Y(J) * H(I,J)
      SUM = SUM + Y(J) * H(I,J)
   50 CONTINUE
cxx   60 WRK(I) = SUM
      WRK(I) = SUM
   60 CONTINUE
      S1 = 0.0D00
      S2 = 0.0D00
      DO  70   I=1,N
      S1 = S1 + WRK(I) * Y(I)
cxx   70 S2 = S2 + DX(I) * Y(I)
      S2 = S2 + DX(I) * Y(I)
   70 CONTINUE
      IF( S1.LE.CONST1 .OR. S2.LE.CONST1 )  GO TO 900
      IF( S1 .LE. S2 )     GO TO 100
C
C          UPDATE THE INVERSE OF HESSIAN MATRIX
C
C               ---  DAVIDON-FLETCHER-POWELL TYPE CORRECTION  ---
C
cxx      DO  90   I=1,N
      DO  91   I=1,N
      DO  90   J=I,N
      H(I,J) = H(I,J) + DX(I)*DX(J)/S2 - WRK(I)*WRK(J)/S1
cxx   90 H(J,I) = H(I,J)
      H(J,I) = H(I,J)
   90 CONTINUE
   91 CONTINUE
      GO TO  120
C
C               ---  FLETCHER TYPE CORRECTION  ---
C
  100 CONTINUE
      STEM = S1 / S2 + 1.0D00
cxx      DO  110   I=1,N
      DO  111   I=1,N
      DO  110   J=I,N
      H(I,J) = H(I,J)- (DX(I)*WRK(J)+WRK(I)*DX(J)-DX(I)*DX(J)*STEM)/S2
cxx  110 H(J,I) = H(I,J)
      H(J,I) = H(I,J)
  110 CONTINUE
  111 CONTINUE
C
C
C
  120 CONTINUE
      SS = 0.0D00
      DO  150   I=1,N
      SUM = 0.0D00
      DO  140   J=1,N
cxx  140 SUM = SUM + H(I,J)*G(J)
      SUM = SUM + H(I,J)*G(J)
  140 CONTINUE
      SS = SS + SUM * SUM
cxx  150 S(I) = -SUM
      S(I) = -SUM
  150 CONTINUE
C
C
      S1 = 0.0D00
      S2 = 0.0D00
      DO  170   I=1,N
      S1 = S1 + S(I)*G(I)
cxx  170 S2 = S2 + G(I)*G(I)
      S2 = S2 + G(I)*G(I)
  170 CONTINUE
      DS2 = DSQRT(S2)
      GTEM = DABS(S1) / DS2
      IF( GTEM .LE. TAU1  .AND.  DS2 .LE. TAU2 )     GO TO  900
      IF( S1 .LT. 0.0D00 )     GO TO  200
      H(1:N,1:N) = 0.0D00
      DO  190   I=1,N
cxx      DO  180   J=1,N
cxx  180 H(I,J) = 0.0D00
      H(I,I) = 1.0D00
cxx  190 S(I) = -S(I)
      S(I) = -S(I)
  190 CONTINUE
  200 CONTINUE
C
      ED = XM
C
C          LINEAR  SEARCH
C
cc      CALL  LINEAR( FUNCT,X,S,RAMDA,ED,N,IG )
cxx      CALL  LINEAR( FUNCT,Z,NZ,X,S,RAMDA,ED,N,R,AIC,SD,F,ISW,IPR,IG,
ccx     *              IFG,LU )
cx     *              IFG,LU,JER )
cxx     *              JER )
      CALL  LINEAR( FUNCT,Z,NZ,X,S,RAMDA,ED,N,R,AIC,SD,F,ISW,IG,JER )
      IF( JER .NE. 0 ) RETURN
C
cc      IF( IPR .GE. 2 )   WRITE( 6,330 )   RAMDA, F, SD, AIC
cx      IF( (IPR.GE.2) .AND. (IFG.NE.0) )
cx     *                     WRITE( LU,330 )  RAMDA, F, SD, AIC
C
      S1 = 0.0D00
      DO  210   I=1,N
      DX(I) = S(I) * RAMDA
      S1 = S1 + DX(I) * DX(I)
      G0(I) = G(I)
cxx  210 X(I) = X(I) + DX(I)
      X(I) = X(I) + DX(I)
  210 CONTINUE
      XMB = XM
      ISW = 0
C
cc      CALL  FUNCT( N,X,XM,G,IG )
cx      CALL  FUNCT( Z,NZ,N,X,R,ISW,XM,G,AIC,SD,F,IG )
      CALL  FUNCT( Z,NZ,N,X,R,ISW,XM,G,AIC,SD,F,IG,JER )
      IF( JER .NE. 0 ) RETURN
C
      S2 = 0.D0
      DO  220     I=1,N
cxx  220 S2 = S2 + G(I)*G(I)
      S2 = S2 + G(I)*G(I)
  220 CONTINUE
      IF( DSQRT(S2) .GT. TAU2 )   GO TO  11111
      IF( XMB/XM-1.D0 .LT. EPS1  .AND.  DSQRT(S1) .LT. EPS2 )  GO TO 900
11111 CONTINUE
      IF( ICC .GE. 5 )     GO TO 900
      GO TO 11110
  900 CONTINUE
cx      IF( IPR .LE. 0 )   RETURN
cc      WRITE( 6,600 )
cc      WRITE( 6,610 )     (X(I),I=1,N)
cc      WRITE( 6,601 )
cc      WRITE( 6,610 )     (G(I),I=1,N)
cx      IF( IFG .EQ. 0 )   RETURN
cx      WRITE( LU,600 )
cx      WRITE( LU,610 )     (X(I),I=1,N)
cx      WRITE( LU,601 )
cx      WRITE( LU,610 )     (G(I),I=1,N)
      RETURN
cxx  330 FORMAT( 1H ,'LAMBDA =',D15.7,3X,'(-1)LOG LIKELIHOOD =',D23.15,3X,
cxx     * 'SD =',D22.15,5X,'AIC =',D23.15 )
cxx  340 FORMAT( 1H ,26X,'(-1)LOG-LIKELIHOOD =',D23.15,3X,'SD =',D22.15,5X,
cxx     *  'AIC =',D23.15 )
cxx  600 FORMAT( 1H ,'-----  X  -----' )
cxx  601 FORMAT( 1H ,'***  GRADIENT  ***' )
cxx  610 FORMAT( 1H ,10D13.5 )
      END
cc      SUBROUTINE  FUNCT( M,A,F,G,IFG )
cx      SUBROUTINE  FUNCT( Z,N,M,A,R,ISW,F,G,AIC,SD,FF,IFG )
      SUBROUTINE  FUNCT( Z,N,M,A,R,ISW,F,G,AIC,SD,FF,IFG,JER )
C
C     THIS SUBROUTINE COMPUTES THE EXACT LIKELIHOOD AND ITS GRADIENT OF
C     THE M-TH ORDER AR-MODEL.
C       ----------------------------------------------------------------
C       THE FOLLOWING SUBROUTINES ARE DIRECTLY CALLED BY THIS SUBROUTINE
C             ARCOEF
C             PARCOR
C             SUBDET
C       ----------------------------------------------------------------
C
C          INPUTS:
C             M:    ORDER OF THE AR MODEL
C             A:    VECTOR OF AR-COEFFICIENTS
C
C          OUTPUTS:
C             F:    LIKELIHOOD OF THE AR-MODEL
C             G:    GRADIENT OF THE LIKELIHOOD FUNCTION
C             IFG:  =0    ;IF MODEL IS STATIONALY
C                   =1    ;IF MODEL IS NON-STATIONALY
C
C
cxx      IMPLICIT  REAL * 8  ( A-H , O-Z )
CC      REAL * 4   Z
cc      DIMENSION  Z(10000)
CC      COMMON     / AAA /  N , Z(1)
cc      COMMON     / AAA /  N
cc      COMMON     / BBB /  Z
cc      COMMON     / CCC /  ISW, IDUMMY
cc      COMMON     / DDD /  R , FF , AIC , SD
cc      DIMENSION   R(31,31) , T(31,31) , U(31,31) , S(31,31)
cc      DIMENSION   A(20) , B(30) , G(30)
cxx      DIMENSION   Z(N)
cxx      DIMENSION   R(M+1,M+1) , T(M+1,M+1) , U(M+1,M+1) , S(M+1,M+1)
cxx      DIMENSION   A(M) , B(M) , G(M)
      INTEGER :: N, M, ISW, IFG, JER
      REAL(8) :: Z(N), A(M), R(M+1,M+1), F, G(M), AIC, SD, FF
      REAL(8) :: T(M+1,M+1), U(M+1,M+1), S(M+1,M+1), B(M),
     1           DN, DN1, SUM, DSD, USUM, DETT, UDET
cc      MJ = 31
      MJ = M+1
C
  280 IFG = 0
C
      DN = N
      DN1 = 1.0D00 / DN
      MP1 = M + 1
      M1 = MP1 / 2
C
C   **  COMPUTATION OF F  **
C
C
C          INVERSE OF COVARIANCE MATRIX COMPUTATION
C
C
      T(1,1) = 1.0D00 - A(M) * A(M)
      IF( M .EQ. 1 )     GO TO 45
      DO  10     I=2,M
      IM1 = I - 1
      II = M - IM1
cxx   10 T(I,1) = - ( A(IM1)+A(M)*A(II) )
      T(I,1) = - ( A(IM1)+A(M)*A(II) )
   10 CONTINUE
      IF( M .EQ. 2 )     GO TO 25
C
cxx      DO  20     J=2,M1
      DO  21     J=2,M1
      JM1 = J - 1
      JJ = M - JM1
      DO  20     I=J,JJ
      IM1 = I - 1
      II = M - IM1
cxx   20 T(I,J) = T(IM1,JM1) + A(IM1)*A(JM1) - A(II)*A(JJ)
      T(I,J) = T(IM1,JM1) + A(IM1)*A(JM1) - A(II)*A(JJ)
   20 CONTINUE
   21 CONTINUE
C
cxx   25 DO  30     J=1,M1
   25 DO  31     J=1,M1
      JE = MP1 - J
      JE1 = JE - 1
      DO  30     I=J,JE1
      II = MP1 - I
cxx   30 T(JE,II) = T(I,J)
      T(JE,II) = T(I,J)
   30 CONTINUE
   31 CONTINUE
cxx      DO  40     I=2,M
      DO  41     I=2,M
      IM1 = I - 1
      DO  40     J=1,IM1
cxx   40 T(J,I) = T(I,J)
      T(J,I) = T(I,J)
   40 CONTINUE
   41 CONTINUE
C
   45 CONTINUE
C
C         INNOVATION VARIANCE COMPUTATION
C
      SD = R(1,1)
      DO  60     J=1,M
      J1 = J + 1
      SUM = 0.0D00
      DO  50     K=1,M
cxx   50 SUM = SUM + A(K)*R(J1,K+1)
      SUM = SUM + A(K)*R(J1,K+1)
   50 CONTINUE
cxx   60 SD = SD + SUM*A(J)
      SD = SD + SUM*A(J)
   60 CONTINUE
      SUM = 0.0D00
      DO  70     K=1,M
cxx   70 SUM = SUM + A(K)*R(1,K+1)
      SUM = SUM + A(K)*R(1,K+1)
   70 CONTINUE
      SD = SD - 2.0D00*SUM
C
      DO  80     J=1,M
      SUM = 0.0D00
      DO  85     K=1,M
cxx   85 SUM = SUM + T(J,K)*Z(K)
      SUM = SUM + T(J,K)*Z(K)
   85 CONTINUE
cxx   80 SD = SD + SUM*Z(J)
      SD = SD + SUM*Z(J)
   80 CONTINUE
      SD = SD * DN1
C                                                    DS     ) 033,6 (ETI
cxx      DO  90     I=1,M
      DO  91     I=1,M
      DO  90     J=1,M
cxx   90 U(I,J) = T(I,J)
      U(I,J) = T(I,J)
   90 CONTINUE
   91 CONTINUE
      CALL  SUBDET( U,DETT,M,MJ )
C
C         CHECK THE STATIONARITY
C
C
      CALL  PARCOR( A,M,B )
C
      DO  210     I=1,M
      IF( DABS(B(I)) .LT. 1.D0 )     GO TO  210
      IF( ISW .EQ. 0 )   B(I) = 0.999D0*DABS(B(I))/B(I)
      IFG = 1
  210 CONTINUE
      IF( IFG .EQ. 0 )     GO TO  220
      IF( ISW .EQ. 1 )     RETURN
C
      CALL  ARCOEF( B,M,A )
      GO TO  280
  220 CONTINUE
      IF( SD .GT. 0.0D00 ) GO TO 221
      JER = 11111
      RETURN
  221 CONTINUE
C
C         LIKELIHOOD
C
      F = 0.5D00 * ( DN*DLOG(SD) - DLOG(DETT) )
      FF = F
      AIC = 2.D0*F + 2*(M+1)
C
      IF( ISW .EQ. 1 )     RETURN
C
C       COMPUTATION OF GRADIENT OF F
C
      DO  1000     JC=1,M
C
      S(1,1) = 0.0D00
      IF( JC .EQ. M )     S(1,1) = -2.0D00*A(M)
      IF( M .EQ. 1 )     GO TO 145
C
      DO  100     I=2,M
      II = MP1 - I
      IM1 = I - 1
      S(I,1) = 0.0D00
      IF( II .EQ. JC )     S(I,1) = -A(M)
      IF( M .EQ. JC )     S(I,1) = -A(II)
      IF( IM1 .EQ. JC )     S(I,1) = S(I,1) - 1.0D00
  100 CONTINUE
      IF( M .EQ. 2 )     GO TO 120
C
cxx      DO  110     K=2,M1
      DO  111     K=2,M1
      KM1 = K - 1
      KK = MP1 - K
      DO  110     I=K,KK
      IM1 = I - 1
      II = MP1 - I
      S(I,K) = S(IM1,KM1)
      IF( KM1 .EQ. JC )     S(I,K) = S(I,K) + A(IM1)
      IF( IM1 .EQ. JC )     S(I,K) = S(I,K) + A(KM1)
      IF( II .EQ. JC )     S(I,K) = S(I,K) - A(KK)
      IF( KK .EQ. JC )     S(I,K) = S(I,K) - A(II)
  110 CONTINUE
  111 CONTINUE
C
cxx  120 DO  130     J=1,M1
  120 DO  131     J=1,M1
      JE=  MP1 - J
      JE1 = JE - 1
      DO  130     I=J,JE1
      II = MP1 - I
cxx  130 S(JE,II) = S(I,J)
      S(JE,II) = S(I,J)
  130 CONTINUE
  131 CONTINUE
cxx      DO  140     I=2,M
      DO  141     I=2,M
      IM1 = I - 1
      DO  140     J=1,IM1
cxx  140 S(J,I) = S(I,J)
      S(J,I) = S(I,J)
  140 CONTINUE
  141 CONTINUE
  145 CONTINUE
C
C
      J1 = JC + 1
      DSD = R(1,J1)
      DO  150     K=1,M
cxx  150 DSD = DSD - A(K) * R(J1,K+1)
      DSD = DSD - A(K) * R(J1,K+1)
  150 CONTINUE
C
      DSD = -2.0D00*DSD
      DO  170     I=1,M
      SUM = 0.0D00
      DO  160     J=1,M
cxx  160 SUM = SUM + S(I,J)*Z(J)
      SUM = SUM + S(I,J)*Z(J)
  160 CONTINUE
cxx  170 DSD = DSD + SUM*Z(I)
      DSD = DSD + SUM*Z(I)
  170 CONTINUE
      DSD = DSD * DN1
      USUM = 0.0D00
      DO  200     K=1,M
cxx      DO  180     I=1,M
      DO  181     I=1,M
      DO  180     J=1,M
cxx  180 U(I,J) = T(I,J)
      U(I,J) = T(I,J)
  180 CONTINUE
  181 CONTINUE
      DO  190     J=1,M
cxx  190 U(K,J) = S(K,J)
      U(K,J) = S(K,J)
  190 CONTINUE
C
      CALL  SUBDET( U,UDET,M,MJ )
C
cxx  200 USUM = USUM + UDET
      USUM = USUM + UDET
  200 CONTINUE
C
C         GRADIENT OF LIKELIHOOD FUNCTION
C
      G(JC) = 0.5D00*( -DN*DSD/SD + USUM/DETT )
 1000 CONTINUE
      DO  300     I=1,M
cxx  300 G(I) = -G(I)
      G(I) = -G(I)
  300 CONTINUE
      RETURN
      END
cc      SUBROUTINE  HESIAN( X,K,H )
      SUBROUTINE  HESIAN( X,K,N,R,SD,H )
C
C     THIS SUBROUTINE RETURNS THE INVERSE OF AN APPROXIMATION TO THE HES
C     OF LOG-LIKELIHOOD FUNCTION OF THE AUTOREGRESSIVE MODEL OF ORDER K.
C       ----------------------------------------------------------------
C       THE FOLLOWING SUBROUTINE IS DIRECTLY CALLED BY THIS SUBROUTINE:
C             INVDET
C       ----------------------------------------------------------------
C
C       INPUTS:
C          X:     VECTOR OF AR-COEFFICIENTS
C          K:     ORDER OF THE AR-MODEL
C          N:     DATA LENGTH
C          Z:     VECTOR OF ORIGINAL DATA
C          R:     SQUARE ROOT OF THE COVARIANCE MATRIX, OUTPUT OF SUBROU
C                 ARMLE
C          SD:    ESTIMATE OF INNOVATION VARIANCE
C
C       OUTPUT:
C          H:     INVERSE OF THE HESSIAN
cxx      IMPLICIT  REAL*8( A-H,O-Z )
CC      REAL*4  Z
cc      DIMENSION  Z(10000)
CC      COMMON     / AAA /  N , Z(1)
cc      COMMON     / AAA /  N
cc      COMMON     / BBB /  Z
cc      COMMON     / DDD /  R , F , AIC , SD
cc      DIMENSION  R(31,31)
cx      DIMENSION  X(1)
cc      DIMENSION  H(50,50) , S(50)
cxx      DIMENSION  R(K+1,K+1)
cxx      DIMENSION  X(K)
cxx      DIMENSION  H(K,K) , S(K)
      INTEGER :: K, N
      REAL(8) :: X(K), R(K+1,K+1), SD, H(K,K)
      REAL(8) :: S(K), SUM, HDET
      DO 10  I=1,K
      SUM = R(1,I+1)
      DO 20  II=1,K
cxx   20 SUM = SUM - X(II)*R(II+1,I+1)
      SUM = SUM - X(II)*R(II+1,I+1)
   20 CONTINUE
cxx   10 S(I) = SUM / SD
      S(I) = SUM / SD
   10 CONTINUE
cxx      DO 30  I=1,K
      DO 31  I=1,K
      DO 30  J=1,K
cxx   30 H(I,J) = 0.5D0 * (R(I+1,J+1)/SD - S(I)*S(J)/N)
      H(I,J) = 0.5D0 * (R(I+1,J+1)/SD - S(I)*S(J)/N)
   30 CONTINUE
   31 CONTINUE
cc      CALL  INVDET( H,HDET,K,50 )
      CALL  INVDET( H,HDET,K,K )
      RETURN
      E N D
cc      SUBROUTINE  LINEAR( FUNCT,X,H,RAM,EE,K,IG )
cxx      SUBROUTINE  LINEAR( FUNCT,Z,N,X,H,RAM,EE,K,R,AIC,SD,F,ISW,IPR,IG,
ccx     *                    JFG,LU )
cx     *                    JFG,LU,JER )
cxx     *
      SUBROUTINE  LINEAR( FUNCT,Z,N,X,H,RAM,EE,K,R,AIC,SD,F,ISW,IG,JER )
C
C     THIS SUBROUTINE PERFORMS THE LINEAR SEARCH ALONG THE DIRECTION SPE
C     BY THE VECTOR H
C       ----------------------------------------------------------------
C       THE FOLLOWING SUBROUTINE IS DIRECTLY CALLED BY THIS SUBROUTINE:
C             FUNCT
C       ----------------------------------------------------------------
C
C     INPUTS:
C        FUNCT:   EXTERNAL FUNCTION SPECIFICATION
C        X:       VECTOR OF POSITION
C        H:       SEARCH DIRECTION
C        K:       DIMENSION OF VECTOR X
C
C     OUTPUTS:
C        RAM:     OPTIMAL STEP WIDTH
C        E2:      MINIMUM FUNCTION VALUE
C        IG:      ERROR CODE
C
cxx      IMPLICIT  REAL  *8 ( A-H,O-Z )
cxx      INTEGER  RETURN,SUB
cc      DIMENSION  X(1) , H(1) , X1(50)
cc      DIMENSION  G(50)
cc      COMMON     / CCC /  ISW , IPR
cc      DIMENSION  R(31,31)
cxx      DIMENSION  X(K) , H(K) , X1(K)
cxx      DIMENSION  G(K)
cxx      DIMENSION  Z(N)
cxx      DIMENSION  R(K+1,K+1)

      INTEGER :: N, K, ISW, IG, JER
      REAL(8) :: Z(N), X(K), H(K), RAM, EE, R(K+1,K+1), AIC, SD, F
      INTEGER :: RETURN, SUB
      REAL(8) :: X1(K), G(K), CONST2, HNORM, E1, E2, E3,
     1           RAM1, RAM2, RAM3, A1, A2, A3, B1, B2
C
      ISW = 1
      IF( RAM .LE. 1.0D-30 )  RAM = 0.01D0
      CONST2 = 1.0D-60
      HNORM = 0.D0
      DO 10  I=1,K
cxx   10 HNORM = HNORM + H(I)**2
      HNORM = HNORM + H(I)**2
   10 CONTINUE
      HNORM = DSQRT( HNORM )
C
      RAM2 = RAM
      E1 =EE
      RAM1 = 0.D0
C
      DO 20  I=1,K
cxx   20 X1(I) = X(I) + RAM2*H(I)
      X1(I) = X(I) + RAM2*H(I)
   20 CONTINUE
cc      CALL  FUNCT( K,X1,E2,G,IG )
cc      IF(IPR.GE.7)  WRITE(6,2)  RAM2,E2
ccx      CALL  FUNCT( Z,N,K,X1,R,ISW,E2,G,AIC,SD,F,IG )
      CALL  FUNCT( Z,N,K,X1,R,ISW,E2,G,AIC,SD,F,IG,JER )
      IF( JER .NE. 0 ) RETURN
cx      IF( (IPR.GE.7) .AND. (JFG.NE.0) )  WRITE(LU,2)  RAM2,E2
C
      IF( IG .EQ. 1 )  GO TO  50
      IF( E2 .GT. E1 )  GO TO 50
   30 RAM3 = RAM2*2.D0
      DO 40  I=1,K
cxx   40 X1(I) = X(I) + RAM3*H(I)
      X1(I) = X(I) + RAM3*H(I)
   40 CONTINUE
cc      CALL  FUNCT( K,X1,E3,G,IG )
ccx      CALL  FUNCT( Z,N,K,X1,R,ISW,E3,G,AIC,SD,F,IG )
      CALL  FUNCT( Z,N,K,X1,R,ISW,E3,G,AIC,SD,F,IG,JER )
      IF( JER .NE. 0 ) RETURN
      IF( IG.EQ.1 )  GO TO  500
cc      IF( IPR.GE.7 )  WRITE(6,3)  RAM3,E3
cx      IF( (IPR.GE.7) .AND. (JFG.NE.0 ) )  WRITE(LU,3)  RAM3,E3
      IF( E3 .GT. E2 )  GO TO 70
      RAM1 = RAM2
      RAM2 = RAM3
      E1 = E2
      E2 = E3
      GO TO 30
C
   50 RAM3 = RAM2
      E3 = E2
      RAM2 = RAM3*0.1D0
      IF( RAM2*HNORM .LT. CONST2 )  GO TO  400
      DO 60  I=1,K
cxx   60 X1(I) = X(I) + RAM2*H(I)
      X1(I) = X(I) + RAM2*H(I)
   60 CONTINUE
cc      CALL  FUNCT( K,X1,E2,G,IG )
cc      IF(IPR.GE.7)  WRITE(6,4)  RAM2,E2
ccx      CALL  FUNCT( Z,N,K,X1,R,ISW,E2,G,AIC,SD,F,IG )
      CALL  FUNCT( Z,N,K,X1,R,ISW,E2,G,AIC,SD,F,IG,JER )
      IF( JER .NE. 0 ) RETURN
cx      IF( (IPR.GE.7) .AND. (JFG.NE.0) )  WRITE(LU,4)  RAM2,E2
      IF( E2.GT.E1 )  GO TO 50
C
cc   70 ASSIGN 80 TO RETURN
   70 RETURN = 80
      GO TO 200
C
   80 DO 90  I=1,K
cxx   90 X1(I) = X(I) + RAM*H(I)
      X1(I) = X(I) + RAM*H(I)
   90 CONTINUE
cc      CALL  FUNCT( K,X1,EE,G,IG )
cc      IF(IPR.GE.7)  WRITE(6,5)  RAM,EE
ccx      CALL  FUNCT( Z,N,K,X1,R,ISW,EE,G,AIC,SD,F,IG )
      CALL  FUNCT( Z,N,K,X1,R,ISW,EE,G,AIC,SD,F,IG,JER )
      IF( JER .NE. 0 ) RETURN
cx      IF( (IPR.GE.7) .AND. (JFG.NE.0) )  WRITE(LU,5)  RAM,EE
C
      IFG = 0
cc      ASSIGN  300 TO  SUB
cc      ASSIGN 200 TO SUB
cc   95 ASSIGN 130 TO RETURN
      SUB = 300
      SUB = 200
   95 RETURN = 130
      IF( RAM .GT. RAM2 )  GO TO 110
      IF( EE .GE. E2 )  GO TO 100
      RAM3 = RAM2
      RAM2 = RAM
      E3 =E2
      E2 =EE
cc      GO TO  SUB,( 200,300 )
      IF( SUB .EQ. 200 ) GO TO  200
      IF( SUB .EQ. 300 ) GO TO  300
C
  100 RAM1 = RAM
      E1 = EE
cc      GO TO  SUB,( 200,300 )
      IF( SUB .EQ. 200 ) GO TO  200
      IF( SUB .EQ. 300 ) GO TO  300
C
  110 IF( EE .LE. E2 )  GO TO 120
      RAM3 = RAM
      E3 = EE
cc      GO TO  SUB,( 200,300 )
      IF( SUB .EQ. 200 ) GO TO  200
      IF( SUB .EQ. 300 ) GO TO  300
C
  120 RAM1 = RAM2
      RAM2 = RAM
      E1 = E2
      E2 = EE
cc      GO TO  SUB,( 200,300 )
      IF( SUB .EQ. 200 ) GO TO  200
      IF( SUB .EQ. 300 ) GO TO  300
C
  130 DO 140  I=1,K
cxx  140 X1(I) = X(I) + RAM*H(I)
      X1(I) = X(I) + RAM*H(I)
  140 CONTINUE
cc      CALL  FUNCT( K,X1,EE,G,IG )
cc      IF( IPR.GE.7 )  WRITE(6,6)  RAM,EE
ccx      CALL  FUNCT( Z,N,K,X1,R,ISW,EE,G,AIC,SD,F,IG )
      CALL  FUNCT( Z,N,K,X1,R,ISW,EE,G,AIC,SD,F,IG,JER )
      IF ( JER .NE. 0 ) RETURN
cx      IF( (IPR.GE.7)  .AND. (JFG.NE.0) )  WRITE(LU,6)  RAM,EE
cc      ASSIGN 200 TO SUB
      SUB = 200
      IFG = IFG+1
      IFG = 0
      IF( IFG .EQ. 1 )  GO TO 95
C
      IF( E2 .LT. EE )  RAM = RAM2
      RETURN
C
C      -------  INTERNAL SUBROUTINE SUB1  -------
  200 A1 = (RAM3-RAM2)*E1
      A2 = (RAM1-RAM3)*E2
      A3 = (RAM2-RAM1)*E3
      B2 = (A1+A2+A3)*2.D0
      B1 = A1*(RAM3+RAM2) + A2*(RAM1+RAM3) + A3*(RAM2+RAM1)
      IF( B2 .EQ. 0.D0 )  GO TO 210
      RAM = B1 /B2
cc      GO TO RETURN ,( 80,130 )
      IF( RETURN .EQ. 80 ) GO TO 80
      IF( RETURN .EQ. 130 ) GO TO 130
C
  210 IG = 1
      RAM = RAM2
      RETURN
C
C      -------  INTERNAL SUBROUTINE SUB2  -------
C
  300 IF( RAM3-RAM2 .GT. RAM2-RAM1 )  GO TO 310
      RAM = (RAM1+RAM2)*0.5D0
cc      GO TO RETURN ,( 80,130 )
      IF( RETURN .EQ. 80 ) GO TO 80
      IF( RETURN .EQ. 130 ) GO TO 130
C
  310 RAM = (RAM2+RAM3)*0.5D0
cc      GO TO RETURN ,( 80,130 )
      IF( RETURN .EQ. 80 ) GO TO 80
      IF( RETURN .EQ. 130 ) GO TO 130
C ------------------------------------------------------------
C
  400 RAM = 0.D0
      RETURN
C ------------------------------------------------------------
C
  500 RAM = (RAM2+RAM3)*0.5D0
  510 DO 520  I=1,K
cxx  520 X1(I) = X(I) + RAM*H(I)
      X1(I) = X(I) + RAM*H(I)
  520 CONTINUE
cc      CALL  FUNCT( K,X1,E3,G,IG )
cc      IF( IPR.GE.7 )  WRITE(6,7)  RAM,E3
ccx      CALL  FUNCT( Z,N,K,X1,R,ISW,E3,G,AIC,SD,F,IG )
      CALL  FUNCT( Z,N,K,X1,R,ISW,E3,G,AIC,SD,F,IG,JER )
      IF( JER .NE. 0 ) RETURN
cx      IF( (IPR.GE.7) .AND. (JFG.NE.0) )  WRITE(LU,7)  RAM,E3
      IF( IG.EQ.1 )  GO TO 540
      IF( E3.GT.E2 )  GO TO 530
      RAM1 = RAM2
      RAM2 = RAM
      E1 = E2
      E2 = E3
      GO TO 500
C
  530 RAM3 = RAM
      GO TO 70
C
  540 RAM = (RAM2+RAM)*0.5D0
      GO TO 510
C
C ------------------------------------------------------------
cxx    1 FORMAT( 1H ,'LAMBDA =',D18.10, 10X,'E1 =',D25.17 )
cxx    2 FORMAT( 1H ,'LAMBDA =',D18.10, 10X,'E2 =',D25.17 )
cxx    3 FORMAT( 1H ,'LAMBDA =',D18.10, 10X,'E3 =',D25.17 )
cxx    4 FORMAT( 1H ,'LAMBDA =',D18.10, 10X,'E4 =',D25.17 )
cxx    5 FORMAT( 1H ,'LAMBDA =',D18.10, 10X,'E5 =',D25.17 )
cxx    6 FORMAT( 1H ,'LAMBDA =',D18.10, 10X,'E6 =',D25.17 )
cxx    7 FORMAT( 1H ,'LAMBDA =',D18.10, 10X,'E7 =',D25.17 )
      E N D


c       Derivative of chi square in 2D individual channel template matching

	function dchisqr_2D(tau,amp_prof,pha_prof,amp_tmpl,pha_tmpl,nchan,nh,nsum)

	real*8 amp_prof(nchan,nh), pha_prof(nchan,nh)
        real*8 amp_tmpl(nchan,nh), pha_tmpl(nchan,nh)
        real*8 b(nchan)

c       calculate scaling factor b_i for individual channel
        do i=1,nchan
          s1=0.0
          s2=0.0
          do j=1,nsum
            s1=s1+amp_prof(i,j)*amp_tmpl(i,j)
     +         *cos(pha_tmpl(i,j)-pha_prof(i,j)+tau*j)
            s2=s2+amp_tmpl(i,j)**2
          end do
          b(i)=s1/s2
        end do

c       calculate the global dchi^2/dtau
	s=0.0
        do i=1,nchan
          s3=0.0
          do j=1,nsum
            s3=s3+j*amp_prof(i,j)*amp_tmpl(i,j)
     +         *sin(pha_tmpl(i,j)-pha_prof(i,j)+tau*j)
          end do
          s=s+b(i)*s3
c         s=s+s3
        end do

	dchisqr_2D=s

	return
	end


      SUBROUTINE MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, U1, LDU1, U2,
     $                   LDU2, J1, N1, N2, DWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To swap diagonal blocks A11 and A22 of order 1 or 2 in the upper
C     quasi-triangular matrix A contained in a skew-Hamiltonian matrix
C
C                   [  A   G  ]          T
C             X  =  [       T ],   G = -G,
C                   [  0   A  ]
C
C     or in a Hamiltonian matrix
C
C                   [  A   G  ]          T
C             X  =  [       T ],   G =  G.
C                   [  0  -A  ]
C
C     This routine is a modified version of the LAPACK subroutine
C     DLAEX2.
C
C     The matrix A must be in Schur canonical form (as returned by the
C     LAPACK routine DHSEQR), that is, block upper triangular with
C     1-by-1 and 2-by-2 diagonal blocks; each 2-by-2 diagonal block has
C     its diagonal elements equal and its off-diagonal elements of
C     opposite sign.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     ISHAM   LOGIGAL
C             Specifies the type of X:
C             = .TRUE.:   X is a Hamiltonian matrix;
C             = .FALSE.:  X is a skew-Hamiltonian matrix.
C
C     WANTU   LOGIGAL
C             = .TRUE.:   update the matrices U1 and U2 containing the
C                         Schur vectors;
C             = .FALSE.:  do not update U1 and U2.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrix A. N >= 0.
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 upper quasi-triangular matrix A, in Schur
C             canonical form.
C             On exit, the leading N-by-N part of this array contains
C             the reordered matrix A, again in Schur canonical form.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= MAX(1,N).
C
C     G       (input/output) DOUBLE PRECISION array, dimension (LDG,N)
C             On entry, the leading N-by-N part of this array must
C             contain the upper triangular part of the symmetric
C             matrix G, if ISHAM = .TRUE., or the strictly upper
C             triangular part of the skew-symmetric matrix G, otherwise.
C             The rest of this array is not referenced.
C             On exit, the leading N-by-N part of this array contains
C             the upper or strictly upper triangular part of the
C             symmetric or skew-symmetric matrix G, respectively,
C             updated by the orthogonal transformation which reorders A.
C
C     LDG     INTEGER
C             The leading dimension of the array G.  LDG >= MAX(1,N).
C
C     U1      (input/output) DOUBLE PRECISION array, dimension (LDU1,N)
C             On entry, if WANTU = .TRUE., the leading N-by-N part of
C             this array must contain the matrix U1.
C             On exit, if WANTU = .TRUE., the leading N-by-N part of
C             this array contains U1, postmultiplied by the orthogonal
C             transformation which reorders A. See the description in
C             the SLICOT subroutine MB03TD for further details.
C             If WANTU = .FALSE., this array is not referenced.
C
C     LDU1    INTEGER
C             The leading dimension of the array U1.
C             LDU1 >= MAX(1,N),  if WANTU = .TRUE.;
C             LDU1 >= 1,         otherwise.
C
C     U2      (input/output) DOUBLE PRECISION array, dimension (LDU2,N)
C             On entry, if WANTU = .TRUE., the leading N-by-N part of
C             this array must contain the matrix U2.
C             On exit, if WANTU = .TRUE., the leading N-by-N part of
C             this array contains U2, postmultiplied by the orthogonal
C             transformation which reorders A.
C             If WANTU = .FALSE., this array is not referenced.
C
C     LDU2    INTEGER
C             The leading dimension of the array U2.
C             LDU2 >= MAX(1,N),  if WANTU = .TRUE.;
C             LDU2 >= 1,         otherwise.
C
C     J1      (input) INTEGER
C             The index of the first row of the first block A11.
C             If J1+N1 < N, then A11 is swapped with the block starting
C             at (J1+N1+1)-th diagonal element.
C             If J1+N1 > N, then A11 is the last block in A and swapped
C             with -A11', if ISHAM = .TRUE.,
C             or    A11', if ISHAM = .FALSE..
C
C     N1      (input) INTEGER
C             The order of the first block A11. N1 = 0, 1 or 2.
C
C     N2      (input) INTEGER
C             The order of the second block A22. N2 = 0, 1 or 2.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (N)
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             = 1:  the transformed matrix A would be too far from Schur
C                   form; the blocks are not swapped and A, G, U1 and
C                   U2 are unchanged.
C
C     REFERENCES
C
C     [1] Bai, Z., and Demmel, J.W.
C        On swapping diagonal blocks in real Schur form.
C        Linear Algebra Appl., 186, pp. 73-95, 1993.
C
C     [2] Benner, P., Kressner, D., and Mehrmann, V.
C         Skew-Hamiltonian and Hamiltonian Eigenvalue Problems: Theory,
C         Algorithms and Applications. Techn. Report, TU Berlin, 2003.
C
C     CONTRIBUTORS
C
C     D. Kressner, Technical Univ. Berlin, Germany, and
C     P. Benner, Technical Univ. Chemnitz, Germany, December 2003.
C
C     REVISIONS
C
C     V. Sima, May 2008 (SLICOT version of the HAPACK routine DHAEX2).
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, HALF, ONE, TWO, THIRTY, FORTY
      PARAMETER          ( ZERO  = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0,
     $                     TWO   = 2.0D+0, THIRTY = 3.0D+1,
     $                     FORTY = 4.0D+1 )
      INTEGER            LDD, LDX
      PARAMETER          ( LDD = 4, LDX = 2 )
C     .. Scalar Arguments ..
      LOGICAL            ISHAM, WANTU
      INTEGER            INFO, J1, LDA, LDG, LDU1, LDU2, N, N1, N2
C     .. Array Arguments ..
      DOUBLE PRECISION   A(LDA,*), DWORK(*), G(LDG,*), U1(LDU1,*),
     $                   U2(LDU2,*)
C     .. Local Scalars ..
      LOGICAL            LBLK
      INTEGER            IERR, J2, J3, J4, K, ND
      DOUBLE PRECISION   A11, A22, A33, CS, DNORM, EPS, SCALE, SMLNUM,
     $                   SN, TAU, TAU1, TAU2, TEMP, THRESH, WI1, WI2,
     $                   WR1, WR2, XNORM
C     .. Local Arrays ..
      DOUBLE PRECISION   D(LDD,4), V(3), V1(3), V2(3), X(LDX,2)
C     .. External Functions ..
      DOUBLE PRECISION   DDOT, DLAMCH, DLANGE
      EXTERNAL           DDOT, DLAMCH, DLANGE
C     .. External Subroutines ..
      EXTERNAL           DAXPY, DLACPY, DLANV2, DLARFG, DLARFX, DLARTG,
     $                   DLASET, DLASY2, DROT, DSCAL, DSWAP, DSYMV,
     $                   DSYR2, MB01MD, MB01ND
C     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX
C
C     .. Executable Statements ..
C
      INFO = 0
C
C     Quick return if possible.
C
      IF ( N.EQ.0 .OR. N1.EQ.0 .OR. N2.EQ.0 )
     $   RETURN
      LBLK = ( J1+N1.GT.N )
C
      J2 = J1 + 1
      J3 = J1 + 2
      J4 = J1 + 3
C
      IF ( LBLK .AND. N1.EQ.1 ) THEN
C
         IF ( ISHAM ) THEN
            A11 = A(N,N)
            CALL DLARTG( G(N,N), -TWO*A11, CS, SN, TEMP )
            CALL DROT( N-1, A(1,N), 1, G(1,N), 1, CS, SN )
            A(N,N) = -A11
            IF ( WANTU )
     $         CALL DROT( N, U1(1,N), 1, U2(1,N), 1, CS, SN )
         ELSE
            CALL DSWAP( N-1, A(1,N), 1, G(1,N), 1 )
            CALL DSCAL( N-1, -ONE, A(1,N), 1 )
            IF ( WANTU ) THEN
               CALL DSWAP( N, U1(1,N), 1, U2(1,N), 1 )
               CALL DSCAL( N, -ONE, U1(1,N), 1 )
            END IF
         END IF
C
      ELSE IF ( LBLK .AND. N1.EQ.2 ) THEN
C
         IF ( ISHAM ) THEN
C
C           Reorder Hamiltonian matrix:
C
C                      [ A11  G11  ]
C                      [         T ].
C                      [  0  -A11  ]
C
            ND = 4
            CALL DLACPY( 'Full', 2, 2, A(N-1,N-1), LDA, D, LDD )
            CALL DLASET( 'All', 2, 2, ZERO, ZERO, D(3,1), LDD )
            CALL DLACPY( 'Upper', 2, 2, G(N-1,N-1), LDG, D(1,3), LDD )
            D(2,3) = D(1,4)
            D(3,3) = -D(1,1)
            D(4,3) = -D(1,2)
            D(3,4) = -D(2,1)
            D(4,4) = -D(2,2)
            DNORM = DLANGE( 'Max', ND, ND, D, LDD, DWORK )
C
C           Compute machine-dependent threshold for test for accepting
C           swap.
C
            EPS = DLAMCH( 'P' )
            SMLNUM = DLAMCH( 'S' ) / EPS
            THRESH = MAX( FORTY*EPS*DNORM, SMLNUM )
C
C           Solve A11*X + X*A11' = scale*G11 for X.
C
            CALL DLASY2( .FALSE., .FALSE., -1, 2, 2, D, LDD, D(3,3),
     $                   LDD, D(1,3), LDD, SCALE, X, LDX, XNORM, IERR )
C
C           Compute symplectic QR decomposition of
C
C                  (  -X11  -X12 )
C                  (  -X21  -X22 ).
C                  ( scale    0  )
C                  (    0  scale )
C
            TEMP = -X(1,1)
            CALL DLARTG( TEMP, SCALE, V1(1), V2(1), X(1,1) )
            CALL DLARTG( X(1,1), -X(2,1), V1(2), V2(2), TEMP )
            X(1,2) = -X(1,2)
            X(2,2) = -X(2,2)
            X(1,1) = ZERO
            X(2,1) = SCALE
            CALL DROT( 1, X(1,2), 1, X(1,1), 1, V1(1), V2(1) )
            CALL DROT( 1, X(1,2), 1, X(2,2), 1, V1(2), V2(2) )
            CALL DROT( 1, X(1,1), 1, X(2,1), 1, V1(2), V2(2) )
            CALL DLARTG( X(2,2), X(2,1), V1(3), V2(3), TEMP )
C
C           Perform swap provisionally on D.
C
            CALL DROT( 4, D(1,1), LDD, D(3,1), LDD, V1(1), V2(1) )
            CALL DROT( 4, D(1,1), LDD, D(2,1), LDD, V1(2), V2(2) )
            CALL DROT( 4, D(3,1), LDD, D(4,1), LDD, V1(2), V2(2) )
            CALL DROT( 4, D(2,1), LDD, D(4,1), LDD, V1(3), V2(3) )
            CALL DROT( 4, D(1,1), 1, D(1,3), 1, V1(1), V2(1) )
            CALL DROT( 4, D(1,1), 1, D(1,2), 1, V1(2), V2(2) )
            CALL DROT( 4, D(1,3), 1, D(1,4), 1, V1(2), V2(2) )
            CALL DROT( 4, D(1,2), 1, D(1,4), 1, V1(3), V2(3) )
C
C           Test whether to reject swap.
C
            IF ( MAX( ABS( D(3,1) ), ABS( D(3,2) ), ABS( D(4,1) ),
     $                ABS( D(4,2) ) ).GT.THRESH ) GO TO 50
C
            CALL DLACPY( 'All', 2, 2, D(1,1), LDD, A(N-1,N-1), LDA )
            CALL DLACPY( 'Upper', 2, 2, D(1,3), LDD, G(N-1,N-1), LDG )
C
            IF ( N.GT.2 ) THEN
               CALL DROT( N-2, A(1,N-1), 1, G(1,N-1), 1, V1(1), V2(1) )
               CALL DROT( N-2, A(1,N-1), 1, A(1,N), 1, V1(2), V2(2) )
               CALL DROT( N-2, G(1,N-1), 1, G(1,N), 1, V1(2), V2(2) )
               CALL DROT( N-2, A(1,N), 1, G(1,N), 1, V1(3), V2(3) )
            END IF
C
            IF ( WANTU ) THEN
               CALL DROT( N, U1(1,N-1), 1, U2(1,N-1), 1, V1(1), V2(1) )
               CALL DROT( N, U1(1,N-1), 1, U1(1,N), 1, V1(2), V2(2) )
               CALL DROT( N, U2(1,N-1), 1, U2(1,N), 1, V1(2), V2(2) )
               CALL DROT( N, U1(1,N), 1, U2(1,N), 1, V1(3), V2(3) )
            END IF
C
         ELSE
C
            IF ( ABS( A(N-1,N) ).GT.ABS( A(N,N-1) ) ) THEN
               TEMP = G(N-1,N)
               CALL DLARTG( TEMP, A(N-1,N), CS, SN, G(N-1,N) )
               SN = -SN
               CALL DROT(N-2, A(1,N), 1, G(1,N), 1, CS, SN )
C
               A(N-1,N) = -SN*A(N,N-1)
               TEMP = -CS*A(N,N-1)
               A(N,N-1) = G(N-1,N)
               G(N-1,N) = TEMP
               IF ( WANTU )
     $            CALL DROT( N, U1(1,N), 1, U2(1,N), 1, CS, SN )
               CALL DSWAP( N-2, A(1,N-1), 1, G(1,N-1), 1 )
               CALL DSCAL( N-2, -ONE, A(1,N-1), 1 )
               IF ( WANTU ) THEN
                  CALL DSWAP( N, U1(1,N-1), 1, U2(1,N-1), 1 )
                  CALL DSCAL( N, -ONE, U1(1,N-1), 1 )
               END IF
            ELSE
               TEMP = G(N-1,N)
               CALL DLARTG( TEMP, A(N,N-1), CS, SN, G(N-1,N) )
               CALL DROT( N-2, A(1,N-1), 1, G(1,N-1), 1, CS, SN )
               A(N,N-1) = -SN*A(N-1,N)
               A(N-1,N) = CS*A(N-1,N)
               IF ( WANTU )
     $            CALL DROT( N, U1(1,N-1), 1, U2(1,N-1), 1, CS, SN )
               CALL DSWAP( N-1, A(1,N), 1, G(1,N), 1 )
               CALL DSCAL( N-1, -ONE, A(1,N), 1 )
               IF ( WANTU ) THEN
                  CALL DSWAP( N, U1(1,N), 1, U2(1,N), 1 )
                  CALL DSCAL( N, -ONE, U1(1,N), 1 )
               END IF
            END IF
         END IF
C
C        Standardize new 2-by-2 block.
C
         CALL DLANV2( A(N-1,N-1), A(N-1,N), A(N,N-1),
     $                A(N,N), WR1, WI1, WR2, WI2, CS, SN )
         CALL DROT( N-2, A(1,N-1), 1, A(1,N), 1, CS, SN )
         IF ( ISHAM ) THEN
            TEMP = G(N-1,N)
            CALL DROT( N-1, G(1,N-1), 1, G(1,N), 1, CS, SN )
            TAU = CS*TEMP + SN*G(N,N)
            G(N,N) = CS*G(N,N) - SN*TEMP
            G(N-1,N-1) = CS*G(N-1,N-1) + SN*TAU
            CALL DROT( 1, G(N-1,N), LDG, G(N,N), LDG, CS, SN )
         ELSE
            CALL DROT( N-2, G(1,N-1), 1, G(1,N), 1, CS, SN )
         END IF
         IF ( WANTU ) THEN
            CALL DROT( N, U1(1,N-1), 1, U1(1,N), 1, CS, SN )
            CALL DROT( N, U2(1,N-1), 1, U2(1,N), 1, CS, SN )
         END IF
C
      ELSE IF ( N1.EQ.1 .AND. N2.EQ.1 ) THEN
C
C        Swap two 1-by-1 blocks.
C
         A11 = A(J1,J1)
         A22 = A(J2,J2)
C
C        Determine the transformation to perform the interchange.
C
         CALL DLARTG( A(J1,J2), A22-A11, CS, SN, TEMP )
C
C        Apply transformation to the matrix A.
C
         IF ( J3.LE.N )
     $      CALL DROT( N-J1-1, A(J1,J3), LDA, A(J2,J3), LDA, CS, SN )
         CALL DROT( J1-1, A(1,J1), 1, A(1,J2), 1, CS, SN )
C
         A(J1,J1) = A22
         A(J2,J2) = A11
C
C        Apply transformation to the matrix G.
C
         IF ( ISHAM ) THEN
            TEMP = G(J1,J2)
            CALL DROT( J1, G(1,J1), 1, G(1,J2), 1, CS, SN )
            TAU = CS*TEMP + SN*G(J2,J2)
            G(J2,J2) = CS*G(J2,J2) - SN*TEMP
            G(J1,J1) = CS*G(J1,J1) + SN*TAU
            CALL DROT( N-J1, G(J1,J2), LDG, G(J2,J2), LDG, CS, SN )
         ELSE
            IF ( N.GT.J1+1 )
     $         CALL DROT( N-J1-1, G(J1,J1+2), LDG, G(J2,J1+2), LDG, CS,
     $                    SN )
            CALL DROT( J1-1, G(1,J1), 1, G(1,J2), 1, CS, SN )
         END IF
         IF ( WANTU ) THEN
C
C           Accumulate transformation in the matrices U1 and U2.
C
            CALL DROT( N, U1(1,J1), 1, U1(1,J2), 1, CS, SN )
            CALL DROT( N, U2(1,J1), 1, U2(1,J2), 1, CS, SN )
         END IF
C
      ELSE
C
C        Swapping involves at least one 2-by-2 block.
C
C        Copy the diagonal block of order N1+N2 to the local array D
C        and compute its norm.
C
         ND = N1 + N2
         CALL DLACPY( 'Full', ND, ND, A(J1,J1), LDA, D, LDD )
         DNORM = DLANGE( 'Max', ND, ND, D, LDD, DWORK )
C
C        Compute machine-dependent threshold for test for accepting
C        swap.
C
         EPS = DLAMCH( 'P' )
         SMLNUM = DLAMCH( 'S' ) / EPS
         THRESH = MAX( THIRTY*EPS*DNORM, SMLNUM )
C
C        Solve A11*X - X*A22 = scale*A12 for X.
C
         CALL DLASY2( .FALSE., .FALSE., -1, N1, N2, D, LDD,
     $                D(N1+1,N1+1), LDD, D(1,N1+1), LDD, SCALE, X, LDX,
     $                XNORM, IERR )
C
C        Swap the adjacent diagonal blocks.
C
         K = N1 + N1 + N2 - 3
         GO TO ( 10, 20, 30 )K
C
   10    CONTINUE
C
C        N1 = 1, N2 = 2: generate elementary reflector H so that:
C
C        ( scale, X11, X12 ) H = ( 0, 0, * ).
C
         V(1) = SCALE
         V(2) = X(1,1)
         V(3) = X(1,2)
         CALL DLARFG( 3, V(3), V, 1, TAU )
         V(3) = ONE
         A11 = A(J1,J1)
C
C        Perform swap provisionally on diagonal block in D.
C
         CALL DLARFX( 'Left', 3, 3, V, TAU, D, LDD, DWORK )
         CALL DLARFX( 'Right', 3, 3, V, TAU, D, LDD, DWORK )
C
C        Test whether to reject swap.
C
         IF ( MAX( ABS( D(3,1) ), ABS( D(3,2) ), ABS( D(3,3)-A11 ) )
     $        .GT.THRESH ) GO TO 50
C
C        Accept swap: apply transformation to the entire matrix A.
C
         CALL DLARFX( 'Left', 3, N-J1+1, V, TAU, A(J1,J1), LDA, DWORK )
         CALL DLARFX( 'Right', J2, 3, V, TAU, A(1,J1), LDA, DWORK )
C
         A(J3,J1) = ZERO
         A(J3,J2) = ZERO
         A(J3,J3) = A11
C
C        Apply transformation to G.
C
         IF ( ISHAM ) THEN
            CALL DLARFX( 'Right', J1-1, 3, V, TAU, G(1,J1), LDG, DWORK )
            CALL DSYMV( 'Upper', 3, TAU, G(J1,J1), LDG, V, 1, ZERO,
     $                  DWORK, 1 )
            TEMP = -HALF*TAU*DDOT( 3, DWORK, 1, V, 1 )
            CALL DAXPY( 3, TEMP, V, 1, DWORK, 1 )
            CALL DSYR2( 'Upper', 3, -ONE, V, 1, DWORK, 1,
     $                  G(J1,J1), LDG )
            IF ( N.GT.J1+2 )
     $         CALL DLARFX( 'Left', 3, N-J1-2, V, TAU, G(J1,J1+3), LDG,
     $                      DWORK )
         ELSE
            CALL DLARFX( 'Right', J1-1, 3, V, TAU, G(1,J1), LDG, DWORK )
            CALL MB01MD( 'Upper', 3, TAU, G(J1,J1), LDG, V, 1, ZERO,
     $                   DWORK, 1 )
            CALL MB01ND( 'Upper', 3, ONE, V, 1, DWORK, 1, G(J1,J1),
     $                   LDG )
            IF ( N.GT.J1+2 )
     $         CALL DLARFX( 'Left', 3, N-J1-2, V, TAU, G(J1,J1+3), LDG,
     $                      DWORK )
         END IF
C
         IF ( WANTU ) THEN
C
C           Accumulate transformation in the matrices U1 and U2.
C
            CALL DLARFX( 'R', N, 3, V, TAU, U1(1,J1), LDU1, DWORK )
            CALL DLARFX( 'R', N, 3, V, TAU, U2(1,J1), LDU2, DWORK )
         END IF
         GO TO 40
C
   20    CONTINUE
C
C        N1 = 2, N2 = 1: generate elementary reflector H so that:
C
C        H (  -X11 ) = ( * )
C          (  -X21 ) = ( 0 ).
C          ( scale ) = ( 0 )
C
         V(1) = -X(1,1)
         V(2) = -X(2,1)
         V(3) = SCALE
         CALL DLARFG( 3, V(1), V(2), 1, TAU )
         V(1) = ONE
         A33 = A(J3,J3)
C
C        Perform swap provisionally on diagonal block in D.
C
         CALL DLARFX( 'L', 3, 3, V, TAU, D, LDD, DWORK )
         CALL DLARFX( 'R', 3, 3, V, TAU, D, LDD, DWORK )
C
C        Test whether to reject swap.
C
         IF ( MAX( ABS( D(2,1) ), ABS( D(3,1) ), ABS( D(1,1)-A33 ) )
     $       .GT. THRESH ) GO TO 50
C
C        Accept swap: apply transformation to the entire matrix A.
C
         CALL DLARFX( 'Right', J3, 3, V, TAU, A(1,J1), LDA, DWORK )
         CALL DLARFX( 'Left', 3, N-J1, V, TAU, A(J1,J2), LDA, DWORK )
C
         A(J1,J1) = A33
         A(J2,J1) = ZERO
         A(J3,J1) = ZERO
C
C        Apply transformation to G.
C
         IF ( ISHAM ) THEN
            CALL DLARFX( 'Right', J1-1, 3, V, TAU, G(1,J1), LDG, DWORK )
            CALL DSYMV( 'Upper', 3, TAU, G(J1,J1), LDG, V, 1, ZERO,
     $                  DWORK, 1 )
            TEMP = -HALF*TAU*DDOT( 3, DWORK, 1, V, 1 )
            CALL DAXPY( 3, TEMP, V, 1, DWORK, 1 )
            CALL DSYR2( 'Upper', 3, -ONE, V, 1, DWORK, 1, G(J1,J1),
     $                  LDG )
            IF ( N.GT.J1+2 )
     $         CALL DLARFX( 'Left', 3, N-J1-2, V, TAU, G(J1,J1+3), LDG,
     $                      DWORK )
         ELSE
            CALL DLARFX( 'Right', J1-1, 3, V, TAU, G(1,J1), LDG, DWORK )
            CALL MB01MD( 'Upper', 3, TAU, G(J1,J1), LDG, V, 1, ZERO,
     $                   DWORK, 1 )
            CALL MB01ND( 'Upper', 3, ONE, V, 1, DWORK, 1, G(J1,J1),
     $                   LDG )
            IF ( N.GT.J1+2 )
     $         CALL DLARFX( 'Left', 3, N-J1-2, V, TAU, G(J1,J1+3), LDG,
     $                      DWORK )
         END IF
C
         IF ( WANTU ) THEN
C
C           Accumulate transformation in the matrices U1 and U2.
C
            CALL DLARFX( 'R', N, 3, V, TAU, U1(1,J1), LDU1, DWORK )
            CALL DLARFX( 'R', N, 3, V, TAU, U2(1,J1), LDU2, DWORK )
         END IF
         GO TO 40
C
   30    CONTINUE
C
C        N1 = 2, N2 = 2: generate elementary reflectors H(1) and H(2) so
C        that:
C
C        H(2) H(1) (  -X11  -X12 ) = (  *  * )
C                  (  -X21  -X22 )   (  0  * ).
C                  ( scale    0  )   (  0  0 )
C                  (    0  scale )   (  0  0 )
C
         V1(1) = -X(1,1)
         V1(2) = -X(2,1)
         V1(3) = SCALE
         CALL DLARFG( 3, V1(1), V1(2), 1, TAU1 )
         V1(1) = ONE
C
         TEMP  = -TAU1*( X(1,2)+V1(2)*X(2,2) )
         V2(1) = -TEMP*V1(2) - X(2,2)
         V2(2) = -TEMP*V1(3)
         V2(3) = SCALE
         CALL DLARFG( 3, V2(1), V2(2), 1, TAU2 )
         V2(1) = ONE
C
C        Perform swap provisionally on diagonal block in D.
C
         CALL DLARFX( 'L', 3, 4, V1, TAU1, D, LDD, DWORK )
         CALL DLARFX( 'R', 4, 3, V1, TAU1, D, LDD, DWORK )
         CALL DLARFX( 'L', 3, 4, V2, TAU2, D(2,1), LDD, DWORK )
         CALL DLARFX( 'R', 4, 3, V2, TAU2, D(1,2), LDD, DWORK )
C
C        Test whether to reject swap.
C
         IF ( MAX( ABS( D(3,1) ), ABS( D(3,2) ), ABS( D(4,1) ),
     $             ABS( D(4,2) ) ).GT.THRESH ) GO TO 50
C
C        Accept swap: apply transformation to the entire matrix A.
C
         CALL DLARFX( 'L', 3, N-J1+1, V1, TAU1, A(J1,J1), LDA, DWORK )
         CALL DLARFX( 'R', J4, 3, V1, TAU1, A(1,J1), LDA, DWORK )
         CALL DLARFX( 'L', 3, N-J1+1, V2, TAU2, A(J2,J1), LDA, DWORK )
         CALL DLARFX( 'R', J4, 3, V2, TAU2, A(1,J2), LDA, DWORK )
C
         A(J3,J1) = ZERO
         A(J3,J2) = ZERO
         A(J4,J1) = ZERO
         A(J4,J2) = ZERO
C
C        Apply transformation to G.
C
         IF ( ISHAM ) THEN
            CALL DLARFX( 'Right', J1-1, 3, V1, TAU1, G(1,J1), LDG,
     $                   DWORK )
            CALL DSYMV( 'Upper', 3, TAU1, G(J1,J1), LDG, V1, 1, ZERO,
     $                  DWORK, 1 )
            TEMP = -HALF*TAU1*DDOT( 3, DWORK, 1, V1, 1 )
            CALL DAXPY( 3, TEMP, V1, 1, DWORK, 1 )
            CALL DSYR2( 'Upper', 3, -ONE, V1, 1, DWORK, 1,
     $                  G(J1,J1), LDG )
            IF ( N.GT.J1+2 )
     $         CALL DLARFX( 'Left', 3, N-J1-2, V1, TAU1, G(J1,J1+3),
     $                      LDG, DWORK )
C
            CALL DLARFX( 'Right', J2-1, 3, V2, TAU2, G(1,J2), LDG,
     $                   DWORK )
            CALL DSYMV( 'Upper', 3, TAU2, G(J2,J2), LDG, V2, 1, ZERO,
     $                  DWORK, 1 )
            TEMP = -HALF*TAU2*DDOT( 3, DWORK, 1, V2, 1 )
            CALL DAXPY( 3, TEMP, V2, 1, DWORK, 1 )
            CALL DSYR2( 'Upper', 3, -ONE, V2, 1, DWORK, 1, G(J2,J2),
     $                  LDG )
            IF ( N.GT.J2+2 )
     $         CALL DLARFX( 'Left', 3, N-J2-2, V2, TAU2, G(J2,J2+3),
     $                      LDG, DWORK )
         ELSE
            CALL DLARFX( 'Right', J1-1, 3, V1, TAU1, G(1,J1), LDG,
     $                   DWORK )
            CALL MB01MD( 'Upper', 3, TAU1, G(J1,J1), LDG, V1, 1, ZERO,
     $                   DWORK, 1 )
            CALL MB01ND( 'Upper', 3, ONE, V1, 1, DWORK, 1, G(J1,J1),
     $                   LDG )
            IF ( N.GT.J1+2 )
     $         CALL DLARFX( 'Left', 3, N-J1-2, V1, TAU1, G(J1,J1+3),
     $                      LDG, DWORK )
            CALL DLARFX( 'Right', J2-1, 3, V2, TAU2, G(1,J2), LDG,
     $                   DWORK )
            CALL MB01MD( 'Upper', 3, TAU2, G(J2,J2), LDG, V2, 1, ZERO,
     $                   DWORK, 1 )
            CALL MB01ND( 'Upper', 3, ONE, V2, 1, DWORK, 1, G(J2,J2),
     $                   LDG )
            IF ( N.GT.J2+2 )
     $         CALL DLARFX( 'Left', 3, N-J2-2, V2, TAU2, G(J2,J2+3),
     $                      LDG, DWORK )
         END IF
C
         IF ( WANTU ) THEN
C
C           Accumulate transformation in the matrices U1 and U2.
C
            CALL DLARFX( 'R', N, 3, V1, TAU1, U1(1,J1), LDU1, DWORK )
            CALL DLARFX( 'R', N, 3, V2, TAU2, U1(1,J2), LDU1, DWORK )
            CALL DLARFX( 'R', N, 3, V1, TAU1, U2(1,J1), LDU2, DWORK )
            CALL DLARFX( 'R', N, 3, V2, TAU2, U2(1,J2), LDU2, DWORK )
         END IF
C
   40    CONTINUE
C
         IF ( N2.EQ.2 ) THEN
C
C           Standardize new 2-by-2 block A11.
C
            CALL DLANV2( A(J1,J1), A(J1,J2), A(J2,J1), A(J2,J2), WR1,
     $                   WI1, WR2, WI2, CS, SN )
            CALL DROT( N-J1-1, A(J1,J1+2), LDA, A(J2,J1+2), LDA, CS,
     $                 SN )
            CALL DROT( J1-1, A(1,J1), 1, A(1,J2), 1, CS, SN )
            IF ( ISHAM ) THEN
               TEMP = G(J1,J2)
               CALL DROT( J1, G(1,J1), 1, G(1,J2), 1, CS, SN )
               TAU = CS*TEMP + SN*G(J2,J2)
               G(J2,J2) = CS*G(J2,J2) - SN*TEMP
               G(J1,J1) = CS*G(J1,J1) + SN*TAU
               CALL DROT( N-J1, G(J1,J2), LDG, G(J2,J2), LDG, CS, SN )
            ELSE
               IF ( N.GT.J1+1 )
     $            CALL DROT( N-J1-1, G(J1,J1+2), LDG, G(J2,J1+2), LDG,
     $                       CS, SN )
               CALL DROT( J1-1, G(1,J1), 1, G(1,J2), 1, CS, SN )
            END IF
            IF ( WANTU ) THEN
               CALL DROT( N, U1(1,J1), 1, U1(1,J2), 1, CS, SN )
               CALL DROT( N, U2(1,J1), 1, U2(1,J2), 1, CS, SN )
            END IF
         END IF
C
         IF ( N1.EQ.2 ) THEN
C
C           Standardize new 2-by-2 block A22.
C
            J3 = J1 + N2
            J4 = J3 + 1
            CALL DLANV2( A(J3,J3), A(J3,J4), A(J4,J3), A(J4,J4), WR1,
     $                   WI1, WR2, WI2, CS, SN )
            IF ( J3+2.LE.N )
     $         CALL DROT( N-J3-1, A(J3,J3+2), LDA, A(J4,J3+2), LDA, CS,
     $                    SN )
            CALL DROT( J3-1, A(1,J3), 1, A(1,J4), 1, CS, SN )
            IF ( ISHAM ) THEN
               TEMP = G(J3,J4)
               CALL DROT( J3, G(1,J3), 1, G(1,J4), 1, CS, SN )
               TAU = CS*TEMP + SN*G(J4,J4)
               G(J4,J4) = CS*G(J4,J4) - SN*TEMP
               G(J3,J3) = CS*G(J3,J3) + SN*TAU
               CALL DROT( N-J3, G(J3,J4), LDG, G(J4,J4), LDG, CS, SN )
            ELSE
               IF ( N.GT.J3+1 )
     $            CALL DROT( N-J3-1, G(J3,J3+2), LDG, G(J4,J3+2), LDG,
     $                       CS, SN )
               CALL DROT( J3-1, G(1,J3), 1, G(1,J4), 1, CS, SN )
            END IF
            IF ( WANTU ) THEN
               CALL DROT( N, U1(1,J3), 1, U1(1,J4), 1, CS, SN )
               CALL DROT( N, U2(1,J3), 1, U2(1,J4), 1, CS, SN )
            END IF
         END IF
C
      END IF
      RETURN
C
C     Exit with INFO = 1 if swap was rejected.
C
   50 CONTINUE
      INFO = 1
      RETURN
C *** Last line of MB03TS ***
      END


C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      SUBROUTINE CSA3XS (NI,XI,UI,WTS,KNOTS,SSMTH,NDERIV,NXO,NYO,NZO,
     +                  XO,YO,ZO,UO,NWRK,WORK,IER)
C
      DIMENSION XI(3,NI),UI(NI),WTS(*),KNOTS(3),XO(NXO),YO(NYO),
     +          ZO(NZO),UO(NXO,NYO,NZO),WORK(NWRK),NDERIV(3)
      DIMENSION XMN(3),XMX(3),XV(3)
C
C  Check on the number of knots.
C
      NTOT = KNOTS(1)*KNOTS(2)*KNOTS(3)
C
      DO 20 I=1,3
        IF (KNOTS(I) .LT. 4) THEN
          CALL CFAERR (202,' CSA3XS - must have at least four knots in e
     +very coordinate direction',68)
          IER = 202
          RETURN
        ENDIF
   20 CONTINUE
C
C  Check on the size of the workspace.
C
      IF (NWRK .LT. NTOT*(NTOT+3)) THEN
        CALL CFAERR (203,' CSA3XS - workspace too small',29)
        IER = 202
        RETURN
      ENDIF
C
C  Calculate the min and max for the knots as the minimum value of
C  the input data and output data and the maximum of the input and
C  output data.
C
      DO 30 J=1,3
        XMN(J) = XI(J,1)
        XMX(J) = XI(J,1)
        DO 10 I=2,NI
          XMN(J) = MIN(XMN(J),XI(J,I))
          XMX(J) = MAX(XMX(J),XI(J,I))
   10   CONTINUE
   30 CONTINUE
      XMN(1) = MIN(XMN(1),XO(1))
      XMX(1) = MAX(XMX(1),XO(NXO))
      XMN(2) = MIN(XMN(2),YO(1))
      XMX(2) = MAX(XMX(2),YO(NYO))
      XMN(3) = MIN(XMN(3),ZO(1))
      XMX(3) = MAX(XMX(3),ZO(NZO))
C
C  Find the coefficients.
C
      CALL SPLCW(3,XI,3,UI,WTS,NI,XMN,XMX,KNOTS,SSMTH,WORK,NTOT,
     +           WORK(NTOT+1),NWRK-NTOT,IERR)
      IF (IERR .NE. 0) RETURN
C
C  Calculate the approximated values (coefficients are stored at
C  the beginnig of WORK).
C
      DO 60 I=1,NXO
        XV(1) = XO(I)
        DO 40 J=1,NYO
          XV(2) = YO(J)
          DO 50 K=1,NZO
            XV(3) = ZO(K)
            UO(I,J,K) = SPLDE(3,XV,NDERIV,WORK,XMN,XMX,KNOTS,IER)
            IF (IERR .NE. 0) RETURN
   50     CONTINUE
   40   CONTINUE
   60 CONTINUE
C
      RETURN
      END


      FUNCTION dSAHA(THETA,CHI,dU1,dU2)
c	calcula la detivada respecto a t, del logaritmo de la
C     SAHA-EGGERT EQUATION
c	la derivada del logaritmo de saha respecto a pe es -1/pe
      dSAHA=du2-du1+(theta/5040.)*(2.5+chi*THETA*alog(10.))
      RETURN
      END


      SUBROUTINE RIBESL(X,ALPHA,NB,IZE,B,NCALC)
C-------------------------------------------------------------------
C
C  http://www.netlib.org/specfun/ribesl
C
C  This routine calculates Bessel functions I SUB(N+ALPHA) (X)
C  for non-negative argument X, and non-negative order N+ALPHA,
C  with or without exponential scaling.
C
C
C Explanation of variables in the calling sequence
C
C X     - Working precision non-negative real argument for which
C         I's or exponentially scaled I's (I*EXP(-X))
C         are to be calculated.  If I's are to be calculated,
C         X must be less than EXPARG (see below).
C ALPHA - Working precision fractional part of order for which
C         I's or exponentially scaled I's (I*EXP(-X)) are
C         to be calculated.  0 .LE. ALPHA .LT. 1.0.
C NB    - Integer number of functions to be calculated, NB .GT. 0.
C         The first function calculated is of order ALPHA, and the
C         last is of order (NB - 1 + ALPHA).
C IZE   - Integer type.  IZE = 1 if unscaled I's are to calculated,
C         and 2 if exponentially scaled I's are to be calculated.
C B     - Working precision output vector of length NB.  If the routine
C         terminates normally (NCALC=NB), the vector B contains the
C         functions I(ALPHA,X) through I(NB-1+ALPHA,X), or the
C         corresponding exponentially scaled functions.
C NCALC - Integer output variable indicating possible errors.
C         Before using the vector B, the user should check that
C         NCALC=NB, i.e., all orders have been calculated to
C         the desired accuracy.  See error returns below.
C
C
C*******************************************************************
C*******************************************************************
C
C Explanation of machine-dependent constants
C
C   beta   = Radix for the floating-point system
C   minexp = Smallest representable power of beta
C   maxexp = Smallest power of beta that overflows
C   it     = Number of bits in the mantissa of a working precision
C            variable
C   NSIG   = Decimal significance desired.  Should be set to
C            INT(LOG10(2)*it+1).  Setting NSIG lower will result
C            in decreased accuracy while setting NSIG higher will
C            increase CPU time without increasing accuracy.  The
C            truncation error is limited to a relative error of
C            T=.5*10**(-NSIG).
C   ENTEN  = 10.0 ** K, where K is the largest integer such that
C            ENTEN is machine-representable in working precision
C   ENSIG  = 10.0 ** NSIG
C   RTNSIG = 10.0 ** (-K) for the smallest integer K such that
C            K .GE. NSIG/4
C   ENMTEN = Smallest ABS(X) such that X/4 does not underflow
C   XLARGE = Upper limit on the magnitude of X when IZE=2.  Bear
C            in mind that if ABS(X)=N, then at least N iterations
C            of the backward recursion will be executed.  The value
C            of 10.0 ** 4 is used on every machine.
C   EXPARG = Largest working precision argument that the library
C            EXP routine can handle and upper limit on the
C            magnitude of X when IZE=1; approximately
C            LOG(beta**maxexp)
C
C
C     Approximate values for some important machines are:
C
C                        beta       minexp      maxexp       it
C
C  CRAY-1        (S.P.)    2        -8193        8191        48
C  Cyber 180/855
C    under NOS   (S.P.)    2         -975        1070        48
C  IEEE (IBM/XT,
C    SUN, etc.)  (S.P.)    2         -126         128        24
C  IEEE (IBM/XT,
C    SUN, etc.)  (D.P.)    2        -1022        1024        53
C  IBM 3033      (D.P.)   16          -65          63        14
C  VAX           (S.P.)    2         -128         127        24
C  VAX D-Format  (D.P.)    2         -128         127        56
C  VAX G-Format  (D.P.)    2        -1024        1023        53
C
C
C                        NSIG       ENTEN       ENSIG      RTNSIG
C
C CRAY-1        (S.P.)    15       1.0E+2465   1.0E+15     1.0E-4
C Cyber 180/855
C   under NOS   (S.P.)    15       1.0E+322    1.0E+15     1.0E-4
C IEEE (IBM/XT,
C   SUN, etc.)  (S.P.)     8       1.0E+38     1.0E+8      1.0E-2
C IEEE (IBM/XT,
C   SUN, etc.)  (D.P.)    16       1.0D+308    1.0D+16     1.0D-4
C IBM 3033      (D.P.)     5       1.0D+75     1.0D+5      1.0D-2
C VAX           (S.P.)     8       1.0E+38     1.0E+8      1.0E-2
C VAX D-Format  (D.P.)    17       1.0D+38     1.0D+17     1.0D-5
C VAX G-Format  (D.P.)    16       1.0D+307    1.0D+16     1.0D-4
C
C
C                         ENMTEN      XLARGE   EXPARG
C
C CRAY-1        (S.P.)   1.84E-2466   1.0E+4    5677
C Cyber 180/855
C   under NOS   (S.P.)   1.25E-293    1.0E+4     741
C IEEE (IBM/XT,
C   SUN, etc.)  (S.P.)   4.70E-38     1.0E+4      88
C IEEE (IBM/XT,
C   SUN, etc.)  (D.P.)   8.90D-308    1.0D+4     709
C IBM 3033      (D.P.)   2.16D-78     1.0D+4     174
C VAX           (S.P.)   1.17E-38     1.0E+4      88
C VAX D-Format  (D.P.)   1.17D-38     1.0D+4      88
C VAX G-Format  (D.P.)   2.22D-308    1.0D+4     709
C
C*******************************************************************
C*******************************************************************
C
C Error returns
C
C  In case of an error,  NCALC .NE. NB, and not all I's are
C  calculated to the desired accuracy.
C
C  NCALC .LT. 0:  An argument is out of range. For example,
C     NB .LE. 0, IZE is not 1 or 2, or IZE=1 and ABS(X) .GE. EXPARG.
C     In this case, the B-vector is not calculated, and NCALC is
C     set to MIN0(NB,0)-1 so that NCALC .NE. NB.
C
C  NB .GT. NCALC .GT. 0: Not all requested function values could
C     be calculated accurately.  This usually occurs because NB is
C     much larger than ABS(X).  In this case, B(N) is calculated
C     to the desired accuracy for N .LE. NCALC, but precision
C     is lost for NCALC .LT. N .LE. NB.  If B(N) does not vanish
C     for N .GT. NCALC (because it is too small to be represented),
C     and B(N)/B(NCALC) = 10**(-K), then only the first NSIG-K
C     significant figures of B(N) can be trusted.
C
C
C Intrinsic functions required are:
C
C     DBLE, EXP, DGAMMA, GAMMA, INT, MAX, MIN, REAL, SQRT
C
C
C Acknowledgement
C
C  This program is based on a program written by David J.
C  Sookne (2) that computes values of the Bessel functions J or
C  I of real argument and integer order.  Modifications include
C  the restriction of the computation to the I Bessel function
C  of non-negative real argument, the extension of the computation
C  to arbitrary positive order, the inclusion of optional
C  exponential scaling, and the elimination of most underflow.
C  An earlier version was published in (3).
C
C References: "A Note on Backward Recurrence Algorithms," Olver,
C              F. W. J., and Sookne, D. J., Math. Comp. 26, 1972,
C              pp 941-947.
C
C             "Bessel Functions of Real Argument and Integer Order,"
C              Sookne, D. J., NBS Jour. of Res. B. 77B, 1973, pp
C              125-132.
C
C             "ALGORITHM 597, Sequence of Modified Bessel Functions
C              of the First Kind," Cody, W. J., Trans. Math. Soft.,
C              1983, pp. 242-245.
C
C  Latest modification: May 30, 1989
C
C  Modified by: W. J. Cody and L. Stoltz
C               Applied Mathematics Division
C               Argonne National Laboratory
C               Argonne, IL  60439
C
C-------------------------------------------------------------------
      INTEGER IZE,K,L,MAGX,N,NB,NBMX,NCALC,NEND,NSIG,NSTART
CS    REAL              GAMMA,
      DOUBLE PRECISION DGAMMA,                                              CD
     1 ALPHA,B,CONST,CONV,EM,EMPAL,EMP2AL,EN,ENMTEN,ENSIG,
     2 ENTEN,EXPARG,FUNC,HALF,HALFX,ONE,P,PLAST,POLD,PSAVE,PSAVEL,
     3 RTNSIG,SUM,TEMPA,TEMPB,TEMPC,TEST,TOVER,TWO,X,XLARGE,ZERO
      DIMENSION B(NB)
C-------------------------------------------------------------------
C  Mathematical constants
C-------------------------------------------------------------------
CS    DATA ONE,TWO,ZERO,HALF,CONST/1.0E0,2.0E0,0.0E0,0.5E0,1.585E0/
      DATA ONE,TWO,ZERO,HALF,CONST/1.0D0,2.0D0,0.0D0,0.5D0,1.585D0/         CD
C-------------------------------------------------------------------
C  Machine-dependent parameters
C-------------------------------------------------------------------
CS    DATA NSIG,XLARGE,EXPARG /8,1.0E4,88.0E0/
CS    DATA ENTEN,ENSIG,RTNSIG/1.0E38,1.0E8,1.0E-2/
CS    DATA ENMTEN/4.7E-38/
      DATA NSIG,XLARGE,EXPARG /16,1.0D4,709.0D0/                            CD
      DATA ENTEN,ENSIG,RTNSIG/1.0D308,1.0D16,1.0D-4/                        CD
      DATA ENMTEN/8.9D-308/                                                 CD
C-------------------------------------------------------------------
C  Statement functions for conversion
C-------------------------------------------------------------------
CS    CONV(N) = REAL(N)
CS    FUNC(X) = GAMMA(X)
      CONV(N) = DBLE(N)                                                     CD
      FUNC(X) = DGAMMA(X)                                                   CD
C-------------------------------------------------------------------
C Check for X, NB, OR IZE out of range.
C-------------------------------------------------------------------
      IF ((NB.GT.0) .AND. (X .GE. ZERO) .AND.
     1    (ALPHA .GE. ZERO) .AND. (ALPHA .LT. ONE) .AND.
     2    (((IZE .EQ. 1) .AND. (X .LE. EXPARG)) .OR.
     3     ((IZE .EQ. 2) .AND. (X .LE. XLARGE)))) THEN
C-------------------------------------------------------------------
C Use 2-term ascending series for small X
C-------------------------------------------------------------------
            NCALC = NB
            MAGX = INT(X)
            IF (X .GE. RTNSIG) THEN
C-------------------------------------------------------------------
C Initialize the forward sweep, the P-sequence of Olver
C-------------------------------------------------------------------
                  NBMX = NB-MAGX
                  N = MAGX+1
                  EN = CONV(N+N) + (ALPHA+ALPHA)
                  PLAST = ONE
                  P = EN / X
C-------------------------------------------------------------------
C Calculate general significance test
C-------------------------------------------------------------------
                  TEST = ENSIG + ENSIG
                  IF (2*MAGX .GT. 5*NSIG) THEN
                        TEST = SQRT(TEST*P)
                     ELSE
                        TEST = TEST / CONST**MAGX
                  END IF
                  IF (NBMX .GE. 3) THEN
C-------------------------------------------------------------------
C Calculate P-sequence until N = NB-1.  Check for possible overflow.
C-------------------------------------------------------------------
                     TOVER = ENTEN / ENSIG
                     NSTART = MAGX+2
                     NEND = NB - 1
                     DO 100 K = NSTART, NEND
                        N = K
                        EN = EN + TWO
                        POLD = PLAST
                        PLAST = P
                        P = EN * PLAST/X + POLD
                        IF (P .GT. TOVER) THEN
C-------------------------------------------------------------------
C To avoid overflow, divide P-sequence by TOVER.  Calculate
C P-sequence until ABS(P) .GT. 1.
C-------------------------------------------------------------------
                           TOVER = ENTEN
                           P = P / TOVER
                           PLAST = PLAST / TOVER
                           PSAVE = P
                           PSAVEL = PLAST
                           NSTART = N + 1
   60                      N = N + 1
                              EN = EN + TWO
                              POLD = PLAST
                              PLAST = P
                              P = EN * PLAST/X + POLD
                           IF (P .LE. ONE) GO TO 60
                           TEMPB = EN / X
C-------------------------------------------------------------------
C Calculate backward test, and find NCALC, the highest N
C such that the test is passed.
C-------------------------------------------------------------------
                           TEST = POLD*PLAST / ENSIG
                           TEST = TEST*(HALF-HALF/(TEMPB*TEMPB))
                           P = PLAST * TOVER
                           N = N - 1
                           EN = EN - TWO
                           NEND = MIN0(NB,N)
                           DO 80 L = NSTART, NEND
                              NCALC = L
                              POLD = PSAVEL
                              PSAVEL = PSAVE
                              PSAVE = EN * PSAVEL/X + POLD
                              IF (PSAVE*PSAVEL .GT. TEST) GO TO 90
   80                      CONTINUE
                           NCALC = NEND + 1
   90                      NCALC = NCALC - 1
                           GO TO 120
                        END IF
  100                CONTINUE
                     N = NEND
                     EN = CONV(N+N) + (ALPHA+ALPHA)
C-------------------------------------------------------------------
C Calculate special significance test for NBMX .GT. 2.
C-------------------------------------------------------------------
                     TEST = MAX(TEST,SQRT(PLAST*ENSIG)*SQRT(P+P))
                  END IF
C-------------------------------------------------------------------
C Calculate P-sequence until significance test passed.
C-------------------------------------------------------------------
  110             N = N + 1
                     EN = EN + TWO
                     POLD = PLAST
                     PLAST = P
                     P = EN * PLAST/X + POLD
                  IF (P .LT. TEST) GO TO 110
C-------------------------------------------------------------------
C Initialize the backward recursion and the normalization sum.
C-------------------------------------------------------------------
  120             N = N + 1
                  EN = EN + TWO
                  TEMPB = ZERO
                  TEMPA = ONE / P
                  EM = CONV(N) - ONE
                  EMPAL = EM + ALPHA
                  EMP2AL = (EM - ONE) + (ALPHA + ALPHA)
                  SUM = TEMPA * EMPAL * EMP2AL / EM
                  NEND = N - NB
                  IF (NEND .LT. 0) THEN
C-------------------------------------------------------------------
C N .LT. NB, so store B(N) and set higher orders to zero.
C-------------------------------------------------------------------
                        B(N) = TEMPA
                        NEND = -NEND
                        DO 130 L = 1, NEND
  130                      B(N+L) = ZERO
                     ELSE
                        IF (NEND .GT. 0) THEN
C-------------------------------------------------------------------
C Recur backward via difference equation, calculating (but
C not storing) B(N), until N = NB.
C-------------------------------------------------------------------
                           DO 140 L = 1, NEND
                              N = N - 1
                              EN = EN - TWO
                              TEMPC = TEMPB
                              TEMPB = TEMPA
                              TEMPA = (EN*TEMPB) / X + TEMPC
                              EM = EM - ONE
                              EMP2AL = EMP2AL - ONE
                              IF (N .EQ. 1) GO TO 150
                              IF (N .EQ. 2) EMP2AL = ONE
                              EMPAL = EMPAL - ONE
                              SUM = (SUM + TEMPA*EMPAL) * EMP2AL / EM
  140                      CONTINUE
                        END IF
C-------------------------------------------------------------------
C Store B(NB)
C-------------------------------------------------------------------
  150                   B(N) = TEMPA
                        IF (NB .LE. 1) THEN
                           SUM = (SUM + SUM) + TEMPA
                           GO TO 230
                        END IF
C-------------------------------------------------------------------
C Calculate and Store B(NB-1)
C-------------------------------------------------------------------
                        N = N - 1
                        EN = EN - TWO
                        B(N)  = (EN*TEMPA) / X + TEMPB
                        IF (N .EQ. 1) GO TO 220
                        EM = EM - ONE
                        EMP2AL = EMP2AL - ONE
                        IF (N .EQ. 2) EMP2AL = ONE
                        EMPAL = EMPAL - ONE
                        SUM = (SUM + B(N)*EMPAL) * EMP2AL / EM
                  END IF
                  NEND = N - 2
                  IF (NEND .GT. 0) THEN
C-------------------------------------------------------------------
C Calculate via difference equation and store B(N), until N = 2.
C-------------------------------------------------------------------
                     DO 200 L = 1, NEND
                        N = N - 1
                        EN = EN - TWO
                        B(N) = (EN*B(N+1)) / X +B(N+2)
                        EM = EM - ONE
                        EMP2AL = EMP2AL - ONE
                        IF (N .EQ. 2) EMP2AL = ONE
                        EMPAL = EMPAL - ONE
                        SUM = (SUM + B(N)*EMPAL) * EMP2AL / EM
  200                CONTINUE
                  END IF
C-------------------------------------------------------------------
C Calculate B(1)
C-------------------------------------------------------------------
                  B(1) = TWO*EMPAL*B(2) / X + B(3)
  220             SUM = (SUM + SUM) + B(1)
C-------------------------------------------------------------------
C Normalize.  Divide all B(N) by sum.
C-------------------------------------------------------------------
  230             IF (ALPHA .NE. ZERO)
     1               SUM = SUM * FUNC(ONE+ALPHA) * (X*HALF)**(-ALPHA)
                  IF (IZE .EQ. 1) SUM = SUM * EXP(-X)
                  TEMPA = ENMTEN
                  IF (SUM .GT. ONE) TEMPA = TEMPA * SUM
                  DO 260 N = 1, NB
                     IF (B(N) .LT. TEMPA) B(N) = ZERO
                     B(N) = B(N) / SUM
  260             CONTINUE
                  RETURN
C-------------------------------------------------------------------
C Two-term ascending series for small X.
C-------------------------------------------------------------------
               ELSE
                  TEMPA = ONE
                  EMPAL = ONE + ALPHA
                  HALFX = ZERO
                  IF (X .GT. ENMTEN) HALFX = HALF * X
                  IF (ALPHA .NE. ZERO) TEMPA = HALFX**ALPHA /FUNC(EMPAL)
                  IF (IZE .EQ. 2) TEMPA = TEMPA * EXP(-X)
                  TEMPB = ZERO
                  IF ((X+ONE) .GT. ONE) TEMPB = HALFX * HALFX
                  B(1) = TEMPA + TEMPA*TEMPB / EMPAL
                  IF ((X .NE. ZERO) .AND. (B(1) .EQ. ZERO)) NCALC = 0
                  IF (NB .GT. 1) THEN
                     IF (X .EQ. ZERO) THEN
                           DO 310 N = 2, NB
                              B(N) = ZERO
  310                      CONTINUE
                        ELSE
C-------------------------------------------------------------------
C Calculate higher-order functions.
C-------------------------------------------------------------------
                           TEMPC = HALFX
                           TOVER = (ENMTEN + ENMTEN) / X
                           IF (TEMPB .NE. ZERO) TOVER = ENMTEN / TEMPB
                           DO 340 N = 2, NB
                              TEMPA = TEMPA / EMPAL
                              EMPAL = EMPAL + ONE
                              TEMPA = TEMPA * TEMPC
                              IF (TEMPA .LE. TOVER*EMPAL) TEMPA = ZERO
                              B(N) = TEMPA + TEMPA*TEMPB / EMPAL
                              IF ((B(N) .EQ. ZERO) .AND. (NCALC .GT. N))
     1                             NCALC = N-1
  340                      CONTINUE
                     END IF
                  END IF
            END IF
         ELSE
            NCALC = MIN0(NB,0)-1
      END IF
      RETURN
C---------- Last line of RIBESL ----------
      END


*DECK DBESY0
      DOUBLE PRECISION FUNCTION DBESY0 (X)
C***BEGIN PROLOGUE  DBESY0
C***PURPOSE  Compute the Bessel function of the second kind of order
C            zero.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C10A1
C***TYPE      DOUBLE PRECISION (BESY0-S, DBESY0-D)
C***KEYWORDS  BESSEL FUNCTION, FNLIB, ORDER ZERO, SECOND KIND,
C             SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C DBESY0(X) calculates the double precision Bessel function of the
C second kind of order zero for double precision argument X.
C
C Series for BY0        on the interval  0.          to  1.60000E+01
C                                        with weighted error   8.14E-32
C                                         log weighted error  31.09
C                               significant figures required  30.31
C                                    decimal places required  31.73
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  D1MACH, D9B0MP, DBESJ0, DCSEVL, INITDS, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770701  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  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  DBESY0
      DOUBLE PRECISION X, BY0CS(19), AMPL, THETA, TWODPI, XSML,
     1  Y, D1MACH, DCSEVL, DBESJ0
      LOGICAL FIRST
      SAVE BY0CS, TWODPI, NTY0, XSML, FIRST
      DATA BY0CS(  1) / -.1127783939 2865573217 9398054602 8 D-1      /
      DATA BY0CS(  2) / -.1283452375 6042034604 8088453183 8 D+0      /
      DATA BY0CS(  3) / -.1043788479 9794249365 8176227661 8 D+0      /
      DATA BY0CS(  4) / +.2366274918 3969695409 2415926461 3 D-1      /
      DATA BY0CS(  5) / -.2090391647 7004862391 9622395034 2 D-2      /
      DATA BY0CS(  6) / +.1039754539 3905725209 9924657638 1 D-3      /
      DATA BY0CS(  7) / -.3369747162 4239720967 1877534503 7 D-5      /
      DATA BY0CS(  8) / +.7729384267 6706671585 2136721637 1 D-7      /
      DATA BY0CS(  9) / -.1324976772 6642595914 4347606896 4 D-8      /
      DATA BY0CS( 10) / +.1764823261 5404527921 0038936315 8 D-10     /
      DATA BY0CS( 11) / -.1881055071 5801962006 0282301206 9 D-12     /
      DATA BY0CS( 12) / +.1641865485 3661495027 9223718574 9 D-14     /
      DATA BY0CS( 13) / -.1195659438 6046060857 4599100672 0 D-16     /
      DATA BY0CS( 14) / +.7377296297 4401858424 9411242666 6 D-19     /
      DATA BY0CS( 15) / -.3906843476 7104373307 4090666666 6 D-21     /
      DATA BY0CS( 16) / +.1795503664 4361579498 2912000000 0 D-23     /
      DATA BY0CS( 17) / -.7229627125 4480104789 3333333333 3 D-26     /
      DATA BY0CS( 18) / +.2571727931 6351685973 3333333333 3 D-28     /
      DATA BY0CS( 19) / -.8141268814 1636949333 3333333333 3 D-31     /
      DATA TWODPI / 0.6366197723 6758134307 5535053490 057 D0 /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  DBESY0
      IF (FIRST) THEN
         NTY0 = INITDS (BY0CS, 19, 0.1*REAL(D1MACH(3)))
         XSML = SQRT(4.0D0*D1MACH(3))
      ENDIF
      FIRST = .FALSE.
C
      IF (X .LE. 0.D0) CALL XERMSG ('SLATEC', 'DBESY0',
     +   'X IS ZERO OR NEGATIVE', 1, 2)
      IF (X.GT.4.0D0) GO TO 20
C
      Y = 0.D0
      IF (X.GT.XSML) Y = X*X
      DBESY0 = TWODPI*LOG(0.5D0*X)*DBESJ0(X) + .375D0 + DCSEVL (
     1  .125D0*Y-1.D0, BY0CS, NTY0)
      RETURN
C
 20   CALL D9B0MP (X, AMPL, THETA)
      DBESY0 = AMPL * SIN(THETA)
      RETURN
C
      END


! RUN: %python %S/test_folding.py %s %flang_fc1
! Tests folding of FINDLOC, MAXLOC, & MINLOC
module m1
  integer, parameter :: ia1(2:6) = [1, 2, 3, 2, 1]
  integer, parameter :: ia2(2:3,2:4) = reshape([1, 2, 3, 3, 2, 1], shape(ia2))

  logical, parameter :: fi1a = all(findloc(ia1, 1) == 1)
  logical, parameter :: fi1ar = rank(findloc(ia1, 1)) == 1
  logical, parameter :: fi1ak = kind(findloc(ia1, 1, kind=2)) == 2
  logical, parameter :: fi1ad = findloc(ia1, 1, dim=1) == 1
  logical, parameter :: fi1adr = rank(findloc(ia1, 1, dim=1)) == 0
  logical, parameter :: fi1b = all(findloc(ia1, 1, back=.true.) == 5)
  logical, parameter :: fi1c = all(findloc(ia1, 2, mask=[.false., .false., .true., .true., .true.]) == 4)

  logical, parameter :: fi2a = all(findloc(ia2, 1) == [1, 1])
  logical, parameter :: fi2ar = rank(findloc(ia2, 1)) == 1
  logical, parameter :: fi2b = all(findloc(ia2, 1, back=.true.) == [2, 3])
  logical, parameter :: fi2c = all(findloc(ia2, 2, mask=reshape([.false., .false., .true., .true., .true., .false.], shape(ia2))) == [1, 3])
  logical, parameter :: fi2d = all(findloc(ia2, 1, dim=1) == [1, 0, 2])
  logical, parameter :: fi2e = all(findloc(ia2, 1, dim=2) == [1, 3])

  logical, parameter :: xi1a = all(maxloc(ia1) == 3)
  logical, parameter :: xi1ar = rank(maxloc(ia1)) == 1
  logical, parameter :: xi1ak = kind(maxloc(ia1, kind=2)) == 2
  logical, parameter :: xi1ad = maxloc(ia1, dim=1) == 3
  logical, parameter :: xi1adr = rank(maxloc(ia1, dim=1)) == 0
  logical, parameter :: xi1b = all(maxloc(ia1, back=.true.) == 3)
  logical, parameter :: xi1c = all(maxloc(ia1, mask=[.false., .true., .false., .true., .true.]) == 2)
  logical, parameter :: xi1d = all(maxloc(ia1, mask=[.false., .true., .false., .true., .true.], back=.true.) == 4)

  logical, parameter :: xi2a = all(maxloc(ia2) == [1, 2])
  logical, parameter :: xi2ar = rank(maxloc(ia2)) == 1
  logical, parameter :: xi2b = all(maxloc(ia2, back=.true.) == [2, 2])
  logical, parameter :: xi2c = all(maxloc(ia2, mask=reshape([.false., .true., .true., .false., .true., .true.], shape(ia2))) == [2, 1])
  logical, parameter :: xi2d = all(maxloc(ia2, mask=reshape([.false., .true., .true., .false., .true., .true.], shape(ia2)), back=.true.) == [1, 3])
  logical, parameter :: xi2e = all(maxloc(ia2, dim=1) == [2, 1, 1])
  logical, parameter :: xi2f = all(maxloc(ia2, dim=1, back=.true.) == [2, 2, 1])
  logical, parameter :: xi2g = all(maxloc(ia2, dim=2) == [2, 2])

  logical, parameter :: ni1a = all(minloc(ia1) == 1)
  logical, parameter :: ni1ar = rank(minloc(ia1)) == 1
  logical, parameter :: ni1ak = kind(minloc(ia1, kind=2)) == 2
  logical, parameter :: ni1ad = minloc(ia1, dim=1) == 1
  logical, parameter :: ni1adr = rank(minloc(ia1, dim=1)) == 0
  logical, parameter :: ni1b = all(minloc(ia1, back=.true.) == 5)
  logical, parameter :: ni1c = all(minloc(ia1, mask=[.false., .true., .true., .true., .false.]) == 2)
  logical, parameter :: ni1d = all(minloc(ia1, mask=[.false., .true., .true., .true., .false.], back=.true.) == 4)

  logical, parameter :: ni2a = all(minloc(ia2) == [1, 1])
  logical, parameter :: ni2ar = rank(minloc(ia2)) == 1
  logical, parameter :: ni2b = all(minloc(ia2, back=.true.) == [2, 3])
  logical, parameter :: ni2c = all(minloc(ia2, mask=reshape([.false., .true., .true., .false., .true., .false.], shape(ia2))) == [2, 1])
  logical, parameter :: ni2d = all(minloc(ia2, mask=reshape([.false., .true., .true., .false., .true., .false.], shape(ia2)), back=.true.) == [1, 3])
  logical, parameter :: ni2e = all(minloc(ia2, dim=1) == [1, 1, 2])
  logical, parameter :: ni2f = all(minloc(ia2, dim=1, back=.true.) == [1, 2, 2])
  logical, parameter :: ni2g = all(minloc(ia2, dim=2) == [1, 3])
end module


!##############################################################################
!# ****************************************************************************
!# <name> errest </name>
!# ****************************************************************************
!#
!# <purpose>
!#    This application is used to test error estimation techniques.
!# </purpose>
!##############################################################################

program errest

  use element
  use fsystem
  use genoutput
  use linearsystemscalar
  use linearsystemblock
  use pprocerror
  use pprocgradients
  use pprocindicator
  use spatialdiscretisation
  use storage
  use triangulation
  use ucd

  implicit none

  type(t_triangulation) :: rtriangulation
  type(t_ucdExport) :: rexport, rexportOut
  type(t_vectorScalar) :: rdensity, rpressure, rvelocity_x, rvelocity_y, rvelocity, radvect, rindicator
  type(t_blockDiscretisation) :: rdiscretisation

  real(DP), dimension(:), pointer :: p_Ddensity, p_Dpressure, p_Dvelocity_x, p_Dvelocity_y, p_Dvelocity, p_Dadvect, p_Dindicator
  integer :: nlength

  ! The very first thing in every application:
  ! Initialise system-wide settings:
  call sys_init()

  ! The very second thing in every program:
  ! Initialise the FEAT 2.0 storage management:
  call storage_init(999, 100)

  ! Read GMV file
  call ucd_readGMV ('../flagship/out/zpinch_energy_AMR4_tria.00008.gmv',&
                    rexport, rtriangulation)
  call ucd_infoVariables(rexport)

  ! Generate discretisation
  call spdiscr_initBlockDiscr(rdiscretisation, 1, rtriangulation)
  call spdiscr_initDiscr_triquad(rdiscretisation%RspatialDiscr(1), &
                                 EL_E001, EL_E011, SPDISC_CUB_AUTOMATIC,&
                                 SPDISC_CUB_AUTOMATIC, rtriangulation)

  ! Create scalar vector
  call lsyssc_createVecByDiscr(rdiscretisation%RspatialDiscr(1), rdensity,  .true.)
  call lsyssc_createVecByDiscr(rdiscretisation%RspatialDiscr(1), rpressure, .true.)
  call lsyssc_createVecByDiscr(rdiscretisation%RspatialDiscr(1), rvelocity, .true.)
  call lsyssc_createVecByDiscr(rdiscretisation%RspatialDiscr(1), rvelocity_x, .true.)
  call lsyssc_createVecByDiscr(rdiscretisation%RspatialDiscr(1), rvelocity_y, .true.)
  call lsyssc_createVecByDiscr(rdiscretisation%RspatialDiscr(1), radvect, .true.)
  call lsyssc_createVector(rindicator, rtriangulation%NEL, .true.)
  call lsyssc_getbase_double(rdensity,  p_Ddensity)
  call lsyssc_getbase_double(rpressure, p_Dpressure)
  call lsyssc_getbase_double(rvelocity, p_Dvelocity)
  call lsyssc_getbase_double(rvelocity_x, p_Dvelocity_x)
  call lsyssc_getbase_double(rvelocity_y, p_Dvelocity_y)
  call lsyssc_getbase_double(radvect,   p_Dadvect)
  call lsyssc_getbase_double(rindicator, p_Dindicator)

  ! Get density values
  call ucd_getVariable(rexport, 'density',    p_Ddensity,  nlength)
  call ucd_getVariable(rexport, 'pressure',   p_Dpressure, nlength)
  call ucd_getVariable(rexport, 'velocity_x', p_Dvelocity_x, nlength)
  call ucd_getVariable(rexport, 'velocity_y', p_Dvelocity_y, nlength)
  call ucd_getVariable(rexport, 'advect',     p_Dadvect,   nlength)

  p_Dvelocity = sqrt(p_Dvelocity_x**2 + p_Dvelocity_y**2)

  ! Compute indicator
  call calcAdaptationIndicator(rtriangulation, p_Ddensity, p_Dpressure,&
                               p_Dvelocity, p_Dadvect, p_Dindicator)

  ! Export gradient values to UCD file
  call ucd_startGMV(rexportOut, UCD_FLAG_STANDARD, rtriangulation, 'indicator.gmv')

  call ucd_addVariableVertexBased(rexportOut, 'density', UCD_VAR_STANDARD, p_Ddensity)
  call ucd_addVariableVertexBased(rexportOut, 'pressure', UCD_VAR_STANDARD, p_Dpressure)
  call ucd_addVariableVertexBased(rexportOut, 'vec_mag', UCD_VAR_STANDARD, p_Dvelocity)
  call ucd_addVariableVertexBased(rexportOut, 'advect', UCD_VAR_STANDARD, p_Dadvect)
  call ucd_addVariableElementBased(rexportOut, 'indicator', UCD_VAR_STANDARD, p_Dindicator)

  call ucd_write(rexportOut)

  ! Release data structures
  call ucd_release(rexport)
  call ucd_release(rexportOut)
  call lsyssc_releaseVector(rdensity)
  call lsyssc_releaseVector(rpressure)
  call lsyssc_releaseVector(rvelocity)
  call lsyssc_releaseVector(rvelocity_x)
  call lsyssc_releaseVector(rvelocity_y)
  call lsyssc_releaseVector(radvect)
  call lsyssc_releaseVector(rindicator)
  call tria_done(rtriangulation)
  call spdiscr_releaseBlockDiscr(rdiscretisation, .true.)

  ! Print out heap statistics - just to check if everything
  ! is cleaned up.
  ! This should display 'Handles in use=0' and 'Memory in use=0'!
  call output_lbrk ()
  call storage_info(.true.)

  ! Clean up the storage management, finish
  call storage_done()

contains

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

  subroutine calcAdaptationIndicator(rtriangulation, Ddensity, Dpressure,&
                                     Dvelocity, Dadvect, Dindicator)

    type(t_triangulation), intent(IN) :: rtriangulation
    real(DP), dimension(:), intent(IN)  :: Ddensity, Dpressure, Dvelocity, Dadvect
    real(DP), dimension(:), intent(OUT) :: Dindicator

    ! local variables
    real(DP), dimension(:,:), pointer :: p_DvertexCoords
    integer, dimension(:,:), pointer :: p_IverticesAtElement, p_IneighboursAtElement
    logical, dimension(:), pointer :: p_BisActiveElement
    real(DP) :: dgradient, dlambda_i, dlambda_j
    integer :: iel,jel,ive,nve,i,j,iprotectLayer

    real(DP), parameter :: dEpsS = 0.2_DP
    real(DP), parameter :: dEpsC = 0.1_DP

    ! Set pointers
    call storage_getbase_double2D(rtriangulation%h_DvertexCoords, p_DvertexCoords)
    call storage_getbase_int2D(rtriangulation%h_IverticesAtElement, p_IverticesAtElement)
    call storage_getbase_int2D(rtriangulation%h_IneighboursAtElement, p_IneighboursAtElement)

    ! Loop over all elements
    elements: do iel = 1, rtriangulation%NEL

      ! Get number of vertices at element
      nve = tria_getNVE(p_IverticesAtElement, iel)

      ! Initialize gradient value
      dgradient = 0.0_DP

      ! Check element for shocks and contact discontinuities
      vertices: do ive = 1, nve

        ! Get global vertex numbers
        i = p_IverticesAtElement(ive, iel)
        j = p_IverticesAtElement(mod(ive,nve)+1, iel)

        ! Compute nodal values of tracer
        dlambda_i = Dadvect(i)/Ddensity(i)
        dlambda_j = Dadvect(j)/Ddensity(j)

        ! Update maximum gradient function
        dgradient = max(dgradient,&
            abs(abs(Ddensity(i))  - abs(Ddensity(j)))  / max(abs(Ddensity(i)),  abs(Ddensity(j))),&
            abs(abs(Dpressure(i)) - abs(Dpressure(j))) / max(abs(Dpressure(i)), abs(Dpressure(j))),&
            abs(abs(dlambda_i)    - abs(dlambda_j))    / max(1e-2, min(abs(dlambda_i), abs(dlambda_j))) )
      end do vertices

      ! If we end up here, then the maximum gradient function is adopted
      Dindicator(iel) = dgradient
    end do elements

!!$    ! Add protection layers
!!$    allocate(p_BisActiveElement(rtriangulation%NEL))
!!$
!!$    do iprotectLayer = 1, 2
!!$
!!$      p_BisActiveElement = .false.
!!$
!!$      do iel = 1, rtriangulation%NEL
!!$
!!$        if (p_BisactiveElement(iel)) cycle
!!$        if (p_Dindicator(iel) .le. 0.8) cycle
!!$
!!$        do ive = 1, tria_getNVE(p_IverticesAtElement, iel)
!!$          jel = p_IneighboursAtElement(ive, iel)
!!$          if (jel .eq. 0) cycle
!!$          if (p_BisactiveElement(jel)) then
!!$            p_Dindicator(jel) = max(p_Dindicator(jel), p_Dindicator(iel))
!!$          else
!!$            if (p_Dindicator(jel) .lt. 0.8) then
!!$              p_Dindicator(jel) = max(p_Dindicator(jel), p_Dindicator(iel))
!!$              p_BisactiveElement(jel) = .true.
!!$            end if
!!$          end if
!!$        end do
!!$      end do
!!$    end do
!!$
!!$    deallocate(p_BisActiveElement)

  end subroutine calcAdaptationIndicator

end program errest