      SUBROUTINE BESIC (Z,N,B,IER)
C
C PACKAGE BESC           (NOTE---DOCUMENTATION FOR INDIVIDUAL ROUTINES
C                        FOLLOWS THE GENERAL PACKAGE INFORMATION.)
C
C LATEST REVISION        NOVEMBER 1978
C
C PURPOSE                TO CALCULATE BESSEL FUNCTIONS I AND J FOR
C                        COMPLEX ARGUMENT AND INTEGER ORDERS.
C
C USAGE                  TO CALCULATE I BESSEL FUNCTIONS---
C
C                          CALL BESIC(Z,N,B,IER)
C
C                        TO CALCULATE J BESSEL FUNCTIONS---
C
C                          CALL BESJC(Z,N,B,IER)
C
C ENTRY POINTS           BESIC,BESJC,B2SLCI
C
C COMMON BLOCKS          NONE
C
C I/O                    NONE, EXCEPT FOR ERROR MESSAGES PRODUCED BY
C                        CALLING THE ERROR HANDLING ROUTINE ULIBER.
C
C REQUIRED LIBRARY       NONE
C ROUTINES
C
C SPECIALIST             RUSSELL K. REW
C
C LANGUAGE               FORTRAN
C
C HISTORY                DAVID J. SOOKNE WROTE THE CORE ROUTINE B2SLCI,
C                        WHICH WAS ORIGINALLY DOUBLE PRECISION.  THE
C                        SINGLE PRECISION VERSION, AND THE USER ENTRIES
C                        BESIC AND BESJC WERE WRITTEN BY RUSSELL K. REW
C                        IN SEPTEMBER, 1977.
C
C SPACE REQUIRED         1712 (OCTAL) = 970 (DECIMAL) ON THE 7600.
C
C PORTABILITY            THIS PACKAGE CONFORMS TO THE 1966 ANSI STANDARD
C                        AS CONFIRMED BY THE PFORT VERIFIER.  THERE ARE
C                        FOUR MACHINE DEPENDENT CONSTANTS IN B2SLCI THAT
C                        ARE DESCRIBED IN COMMENT CARDS.
C
C REQUIRED RESIDENT      ULIBER (AN ERROR ROUTINE),SQRT,EXP,COS,SIN
C ROUTINES
C
C REFERENCES             "BESSEL FUNCTIONS I AND J OF COMPLEX
C                        ARGUMENT AND INTEGER ORDER" AND
C                        "CERTIFICATION OF AN ALGORITHM FOR
C                        BESSEL FUNCTIONS OF COMPLEX ARGUMENT"
C                        BOTH BY DAVID J. SOOKNE, JOURNAL OF REASEARCH
C                        OF THE NATIONAL BUREAU OF STANDARDS-B. MATHE-
C                        MATICAL SCIENCES, VOL. 77A, NOS. 3 AND 4, JULY-
C                        DECEMBER, 1973.
C
C METHOD                 BACKWARD RECURSION WITH STRICT CONTROL OF
C                        ERROR.
C
C-----------------------------------------------------------------------
C
C SUBROUTINE BESIC (Z,N,B,IER)
C
C DIMENSION OF           B(N+1)
C ARGUMENTS
C
C LATEST REVISION        OCTOBER 1978
C
C PURPOSE                TO CALCULATE I BESSEL FUNCTIONS FOR COMPLEX
C                        ARGUMENT AND INTEGER ORDER
C
C USAGE                  CALL BESIC (Z,N,B,IER)
C
C ARGUMENTS
C
C ON INPUT               Z
C                          COMPLEX ARGUMENT FOR WHICH I BESSEL FUNCTIONS
C                          ARE TO BE CALCULATED.  ABS(AIMAG(Z)) MUST BE
C                          LESS THAN THE LARGEST REAL ARGUMENT THAT THE
C                          FORTRAN FUNCTION EXP CAN HANDLE.
C
C                        N
C                          INTEGER, THE HIGHEST ORDER TO BE CALCULATED.
C                          N MUST BE GREATER THAN OR EQUAL TO ZERO.
C
C ON OUTPUT              B
C                          COMPLEX VECTOR OF LENGTH N+1 CONTAINING THE
C                          BESSEL FUNCTION VALUES I-SUB-0(Z),I-SUB-1(Z),
C                          ...,I-SUB-N(Z) IN B(1),B(2),...,B(N+1).
C                        IER
C                          AN INTEGER ERROR FLAG.
C                          =0 IF ALL DESIRED ORDERS HAVE BEEN CALCULATED
C                             SATISFACTORILY,
C                          =1 IF ABS(AIMAG(Z)) IS TOO LARGE,
C                          =2 IF N IS LESS THAN ZERO,
C                          =2+K IF ONLY THE FIRST K RESULTS ARE CORRECT.
C                             IN THE RETURNED VALUES B(M) FOR M GREATER
C                             THAN K, APPROXIMATELY THE LAST
C                             ALOG10(ABS(B(M)/B(K))) SIGNIFICANT DIGITS
C                             ARE IN ERROR.
C
C ENTRY POINTS           BESIC
C
C SPECIAL CONDITIONS     NONE
C
C COMMON BLOCKS          NONE
C
C I/O                    NONE, EXCEPT FOR ERROR MESSAGES PRODUCED BY
C                        CALLING THE ERROR HANDLING ROUTINE ULIBER.
C
C PRECISION              SINGLE
C
C SPECIALIST             RUSS REW, NCAR, BOULDER, COLORADO
C
C ACCURACY               IN TESTS RUN ON THE 7600 WITH ORDERS FROM 0
C                        THROUGH 10 USING RANDOM VALUES OF THE ARGUMENT
C                        WITH ABSOLUTE VALUE LESS THAN 50 BUT
C                        CONCENTRATED AROUND THE ORIGIN, THE MAXIMUM
C                        RELATIVE ERROR (OR ABSOLUTE ERROR WHEN IT WAS
C                        LARGER) OBSERVED WAS ABOUT 8.1E-14.
C
C TIMING                 ON NCAR"S CONTROL DATA 7600, BESIC TAKES ABOUT
C                        .32+.008*N MILLISECONDS WHEN Z=(1.0,1.0).
C
C PORTABILITY            ANSI 1966 STANDARD
C
C
C
C
C
C
      COMPLEX         Z          ,B(100)
      real b2(2, 100)

      DATA IORJ/1/,XLARGE/741.66/

      NB = N+1

      CALL B2SLCI (REAL(Z),AIMAG(Z),NB,IORJ,B2,NCALC)

      do n = 1, nb
         b(n) = cmplx(b2(1,n), b2(2,n))
      end do

      IER = 0
      IF (NCALC .EQ. NB) GO TO 103
      IF (NCALC .GE. 0) GO TO 102
      IF (N .GE. 0) GO TO 101
      IER = 2
      CALL ULIBER (IER,25H IN BESIC, N OUT OF RANGE,25)
      GO TO 103
  101 IER = 1
      CALL ULIBER (IER,25H IN BESIC, X OUT OF RANGE,25)
      GO TO 103
  102 IER = 2+NCALC
      CALL ULIBER (IER,40H IN BESIC, ACCURACY LOST FOR SOME ORDERS,40)
  103 RETURN
      END

c
c***************************************************************************
c

      subroutine b2slci (x,y,nb,ize,b,ncalc)
c
c this routine calculates bessel functions i and j of
c complex argument and integer order.
c
c
c      explanation of variables in the calling sequence
c
c x     real part of the complex argument
c       for which i*s or j*s are to be calculated.  if i*s
c       are to be calculated, abs(x) must not exceed exparg
c       (which see below).
c y     imaginary part of the argument.  if j*s are to be
c       calculated, abs(y) must not exceed exparg.
c nb    integer type.  1 + highest order to be calculated.
c       it must be positive.
c ize   integer type.  zero if j*s are to be calculated, 1
c       if i*s are to be calculated.
c b     real array dimensioned b(2,nb), need not be initialized by user.
c       if the routine terminates normally, (ncalc=nb), it returns
c       j(or i)-sub-zero through j(or i)-sub-nb-minus-one of z in b.
c       the real parts of the results are returned in b(1,n) and the
c       corresponding imaginary parts are returned in b(2,n) for n=1,2,
c       ...,nb.  (in the documentation below, br(n) and bi(n) refer to
c       b(1,n) and b(2,n), respectively.)
c ncalc integer type, need not be initialized by user.
c       before using the results, 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       explanation of machine-dependent constants
c
c nsig  decimal significance desired.  should be set to
c       ifix(alog10(2)*nbit+1), where nbit is the number of
c       bits in the mantissa of a real variable.
c       setting nsig higher will increase cpu time without
c       increasing accuracy, while setting nsig lower will
c       decrease accuracy.  if only single-precision
c       accuracy is desired, replace nbit by the number of
c       bits in the mantissa of a single-precision variable.
c       the relative truncation error is limited to t=.5*10
c       **-nsig for order greater than abs(z), and for order
c       less than abs(z) (general test), the relative error
c       is limited to t for function values of magnitude at
c       least 1, and the absolute error is limited to t for
c       smaller values.
c nten  largest integer k such that 10**k is machine-
c       representable in real.
c largez upper limit on the magnitude of z.  bear in mind
c       that if abs(z)=n, then at least n iterations of the
c       backward recursion will be executed.
c exparg largest real argument that the library
c       exp routine can handle.
c
c
c                            error returns
c
c       let g denote either i or j.
c       in case of an error, ncalc.ne.nb, and not all g*s
c  are calculated to the desired accuracy.
c       if ncalc.lt.0, an argument is out of range.  nb.le.0
c  or ize is neither 0 nor 1 or ize=0 and abs(y).gt.exparg,
c  or ize=1 and abs(x).gt.exparg.  in this case, the vectors
c  br and bi are not calculated, and ncalc is set to
c  min0(nb,0)-1 so ncalc.ne.nb.
c       nb.gt.ncalc.gt.0 will occur if nb.gt.magz and abs(g-
c  sub-nb-of-z/g-sub-magx+np-of-z).lt.10.**(nten/2), i.e. nb
c  is much greater than magz.  in this case, br(n) and bi(n)
c  are calculated to the desired accuracy for n.le.ncalc,
c  but for ncalc.lt.n.le.nb, precision is lost.  if n.gt.
c  ncalc and abs(g(ncalc-1)/g(n-1)).eq.10**-k, then the last
c  k significant figures of g(n-1) (=br(n)+i*bi(n)) are
c  erroneous.  if the user wishes to calculate g(n-1) to
c  higher accuracy, he should use an asymptotic formula for
c  large order.
c
      real            x          ,y          ,b          ,pr         ,
     1                pi         ,plastr     ,plasti     ,poldr      ,
     2                poldi      ,psaver     ,psavei     ,exparg     ,
     3                test       ,tover      ,tempar     ,tempai     ,
     4                tempbr     ,tempbi     ,tempcr     ,tempci     ,
     5                sign       ,sumr       ,sumi       ,zinvr      ,
     6                zinvi
      dimension       b(2,nb)
c
c machine dependent data for 7600 and cray
c
c      data nsig,nten,largez,exparg
c     1    /15,293,100000,741.66e0/
c     data nsig/15/,nten/293/,largez/100000/,exparg/741.66/

C MACHINE DEPENDENT DATA FOR VAX
C
c     DATA NSIG,NTEN,LARGEZ,EXPARG
c    1    /7,38,10000.,88.02/

c
c machine dependent data for IBM 580 workstation
c
c     data nsig/15/,nten/308/,largez/100000/,exparg/709.78/
      data nsig/15/,nten/308/,largez/100000/,exparg/709.78/

      tempar = sqrt(x*x+y*y)
      magz = ifix((tempar))
      if (nb.gt.0 .and. magz.le.largez .and.
     1    ((ize.eq.0 .and. abs(y).le.exparg) .or.
     2                               (ize.eq.1 .and. abs(x).le.exparg)))
     3    go to 101
c
c error return -- z, nb, or ize is out of range
c
      ncalc = min0(nb,0)-1
      return
  101 sign = (float(1-2*ize))
      ncalc = nb
c
c use 2-term ascending series for small z
c
      if (tempar**4 .lt. .1e0**nsig) go to 136
c
c initialize the calculation of the p*s
c
      nbmz = nb-magz
      n = magz+1
      if (abs(x) .lt. abs(y)) go to 102
      zinvr = 1.e0/(x+y*y/x)
      zinvi = -y*zinvr/x
      go to 103
  102 zinvi = -1.e0/(y+x*x/y)
      zinvr = -x*zinvi/y
  103 plastr = 1.e0
      plasti = 0.e0
      pr = sign*(float(2*n))*zinvr
      pi = sign*(float(2*n))*zinvi
      test = 2.e0*1.e1**nsig
      m = 0
      if (nbmz .lt. 3) go to 105
c
c calculate p*s until n=nb-1.  check for possible overflow.
c
c the following devious computation replaces
c     tover=10.0**(nten-nsig)
c and is necessitated by the poor power algorithm on the ncar 7600
c in order to prevent overflow
c
      intemp = nten-nsig
      inhlf = intemp/2
      tover = 10.0**inhlf*10.0**(intemp-inhlf)
      nstart = magz+2
      nend = nb-1
      do 104 n=nstart,nend
         poldr = plastr
         poldi = plasti
         plastr = pr
         plasti = pi
         pr = sign*((float(2*n))*(plastr*zinvr-plasti*zinvi)-poldr)
         pi = sign*((float(2*n))*(plasti*zinvr+plastr*zinvi)-poldi)
         if ((pr/tover)**2+(pi/tover)**2-1.e0) 104,104,106
  104 continue
      n = nend
c
c calculate special significance test for nbmz.gt.2.
c
      tempbi = max(abs(pr),abs(pi))
      tempbi = tempbi*sqrt(2.e0*1.e1**nsig*
     1         sqrt(((pr/tempbi)**2+(pi/tempbi)**2)*
     2                         ((plastr/tempbi)**2+(plasti/tempbi)**2)))
      test = max(test,tempbi)
c
c calculate p*s until significance test is passed.
c
  105 n = n+1
      poldr = plastr
      poldi = plasti
      plastr = pr
      plasti = pi
      pr = sign*((float(2*n))*(plastr*zinvr-plasti*zinvi)-poldr)
      pi = sign*((float(2*n))*(plasti*zinvr+plastr*zinvi)-poldi)
      if ((pr/test)**2+(pi/test)**2 .lt. 1.e0) go to 105
      if (m .eq. 1) go to 110
c
c calculate strict variant of significance test, and
c calculate p*s until this test is passed.
c
      m = 1
      tempbi = max(abs(pr),abs(pi))
      tempbr = sqrt(((pr/tempbi)**2+(pi/tempbi)**2)/
     1                          ((plastr/tempbi)**2+(plasti/tempbi)**2))
      tempbi = (float(n+1))/tempar
      if (tempbr+1.e0/tempbr .gt. 2.e0*tempbi)
     1    tempbr = tempbi+sqrt(tempbi**2-1.e0)
      test = test/sqrt(tempbr-1.e0/tempbr)
      if ((pr/test)**2+(pi/test)**2-1.e0) 105,110,110
  106 nstart = n+1
c
c to avoid overflow, normalize p*s by dividing by tover.
c calculate p*s until unnormalized p would overflow.
c
      pr = pr/tover
      pi = pi/tover
      plastr = plastr/tover
      plasti = plasti/tover
      psaver = pr
      psavei = pi
      tempcr = plastr
      tempci = plasti
      test = 1.e1**(2*nsig)
  107 n = n+1
      poldr = plastr
      poldi = plasti
      plastr = pr
      plasti = pi
      pr = sign*((float(2*n))*(plastr*zinvr-plasti*zinvi)-poldr)
      pi = sign*((float(2*n))*(plasti*zinvr+plastr*zinvi)-poldi)
      if (pr**2+pi**2 .le. test) go to 107
c
c calculate backward test, and find ncalc, the highest n
c such that the test is passed.
c
      tempbr = sqrt((plastr**2+plasti**2)/(poldr**2+poldi**2))
      tempbi = (float(n))/tempar
      if (tempbr+1.e0/tempbr .gt. 2.e0*tempbi)
     1    tempbr = tempbi+sqrt(tempbi**2-1.e0)
      test = .5e0*(1.e0-1.e0/tempbr**2)/1.e1**nsig
      test = ((plastr**2+plasti**2)*test)*((poldr**2+poldi**2)*test)
      pr = plastr*tover
      pi = plasti*tover
      n = n-1
      nend = min0(nb,n)
      do 108 ncalc=nstart,nend
         poldr = tempcr
         poldi = tempci
         tempcr = psaver
         tempci = psavei
         psaver = sign*((float(2*n))*(tempcr*zinvr-tempci*zinvi)-poldr)
         psavei = sign*((float(2*n))*(tempci*zinvr+tempcr*zinvi)-poldi)
         if ((psaver**2+psavei**2)*(tempcr**2+tempci**2)-test)
     1       108,108,109
  108 continue
      ncalc = nend+1
  109 ncalc = ncalc-1
c
c the coefficient of b(n) in the normalization sum is
c m*sqrt(-1)**imag, where m=-2,0, or 2, and imag is 0 or 1.
c calculate recursion rules for m and imag, and initialize
c them.
c
  110 n = n+1
      tempbr = (float(ize))*x+(float(1-ize))*y
      ipos = 0
      if (tempbr) 111,112,111
  111 ipos = ifix((1.1e0*tempbr/abs(tempbr)))
  112 mrecur = 4*((2+ize+ipos)/2)-3-2*(ize+ipos)
      k = 2+ipos+2*ize*ipos**2-ize
      l = n-4*(n/4)
      mlast = 2+8*((k*l)/4)-4*((k*l)/2)
      if (ipos.eq.0 .and. (l.eq.1 .or. l.eq.3)) mlast = 0
      l = l+3-4*((l+3)/4)
      m = 2+8*((k*l)/4)-4*((k*l)/2)
      if (ipos.eq.0 .and. (l.eq.1 .or. l.eq.3)) m = 0
      imrecr = (1-ize)*ipos**2
      imag = imrecr*(l-2*(l/2))
c
c initialize the backward recursion and the normalization
c sum.
c
      tempbr = 0.e0
      tempbi = 0.e0
      if (abs(pi) .gt. abs(pr)) go to 113
      tempar = 1.e0/(pr+pi*(pi/pr))
      tempai = -(pi*tempar)/pr
      go to 114
  113 tempai = -1.e0/(pi+pr*(pr/pi))
      tempar = -(pr*tempai)/pi
  114 if (imag .ne. 0) go to 115
      sumr = (float(m))*tempar
      sumi = (float(m))*tempai
      go to 116
  115 sumr = -(float(m))*tempai
      sumi = (float(m))*tempar
  116 nend = n-nb
      if (nend) 123,120,117
c
c recur backward via difference equation calculating (but
c not storing) br(n) and bi(n) until n=nb.
c
  117 do 119 l=1,nend
         n = n-1
         tempcr = tempbr
         tempci = tempbi
         tempbr = tempar
         tempbi = tempai
         pr = (float(2*n))*zinvr
         pi = (float(2*n))*zinvi
         tempar = pr*tempbr-pi*tempbi-sign*tempcr
         tempai = pr*tempbi+pi*tempbr-sign*tempci
         imag = (1-imag)*imrecr
         k = mlast
         mlast = m
         m = k*mrecur
         if (imag .ne. 0) go to 118
         sumr = sumr+(float(m))*tempar
         sumi = sumi+(float(m))*tempai
         go to 119
  118    sumr = sumr-(float(m))*tempai
         sumi = sumi+(float(m))*tempar
  119 continue
c
c store br(nb), bi(nb)
c
  120 b(1,n) = tempar
      b(2,n) = tempai
      if (n .gt. 1) go to 121
c
c nb=1.  since 2*tempar and 2*tempai were added to sumr and
c sumi respectively, we must subtract tempar and tempai
c
      sumr = sumr-tempar
      sumi = sumi-tempai
      go to 130
c
c calculate and store br(nb-1),bi(nb-1)
c
  121 n = n-1
      pr = (float(2*n))*zinvr
      pi = (float(2*n))*zinvi
      b(1,n) = pr*tempar-pi*tempai-sign*tempbr
      b(2,n) = pr*tempai+pi*tempar-sign*tempbi
      if (n .eq. 1) go to 129
      imag = (1-imag)*imrecr
      k = mlast
      mlast = m
      m = k*mrecur
      if (imag .ne. 0) go to 122
      sumr = sumr+(float(m))*b(1,n)
      sumi = sumi+(float(m))*b(2,n)
      go to 125
  122 sumr = sumr-(float(m))*b(2,n)
      sumi = sumi+(float(m))*b(1,n)
      go to 125
c
c n.lt.nb, so store br(n), bi(n), and set higher orders zero
c
  123 b(1,n) = tempar
      b(2,n) = tempai
      nend = -nend
      do 124 l=1,nend
         b(1,n+l) = 0.e0
         b(2,n+l) = 0.e0
  124 continue
  125 nend = n-2
      if (nend .eq. 0) go to 128
c
c calculate via difference equation and store br(n),bi(n),
c until n=2
c
      do 127 l=1,nend
         n = n-1
         pr = (float(2*n))*zinvr
         pi = (float(2*n))*zinvi
         b(1,n) = pr*b(1,n+1)-pi*b(2,n+1)-sign*b(1,n+2)
         b(2,n) = pr*b(2,n+1)+pi*b(1,n+1)-sign*b(2,n+2)
         imag = (1-imag)*imrecr
         k = mlast
         mlast = m
         m = k*mrecur
         if (imag .ne. 0) go to 126
         sumr = sumr+(float(m))*b(1,n)
         sumi = sumi+(float(m))*b(2,n)
         go to 127
  126    sumr = sumr-(float(m))*b(2,n)
         sumi = sumi+(float(m))*b(1,n)
  127 continue
c
c calculate and store br(1), bi(1)
c
  128 b(1,1) = 2.e0*(b(1,2)*zinvr-b(2,2)*zinvi)-sign*b(1,3)
      b(2,1) = 2.e0*(b(1,2)*zinvi+b(2,2)*zinvr)-sign*b(2,3)
  129 sumr = sumr+b(1,1)
      sumi = sumi+b(2,1)
c
c calculate normalization factor, tempar +i*tempai
c
  130 if (ize .eq. 1) go to 131
      tempcr = (float(ipos))*y
      tempci = (float(-ipos))*x
      go to 132
  131 tempcr = (float(ipos))*x
      tempci = (float(ipos))*y
  132 tempcr = exp(tempcr)
      tempbr = cos(tempci)
      tempbi = sin(tempci)
      if (abs(sumr) .lt. abs(sumi)) go to 133
      tempci = sumi/sumr
      tempcr = (tempcr/sumr)/(1.e0+tempci*tempci)
      tempar = tempcr*(tempbr+tempbi*tempci)
      tempai = tempcr*(tempbi-tempbr*tempci)
      go to 134
  133 tempci = sumr/sumi
      tempcr = (tempcr/sumi)/(1.e0+tempci*tempci)
      tempar = tempcr*(tempbr*tempci+tempbi)
      tempai = tempcr*(tempbi*tempci-tempbr)
c
c normalize
c
  134 do 135 n=1,nb
         tempbr = b(1,n)*tempar-b(2,n)*tempai
         b(2,n) = b(1,n)*tempai+b(2,n)*tempar
         b(1,n) = tempbr
  135 continue
      return
c
c two-term ascending series for small z
c
  136 tempar = 1.e0
      tempai = 0.e0
      tempcr = .25e0*(x*x-y*y)
      tempci = .5e0*x*y
      b(1,1) = 1.e0-sign*tempcr
      b(2,1) = -sign*tempci
      if (nb .eq. 1) go to 138
      do 137 n=2,nb
         tempbr = (tempar*x-tempai*y)/(float(2*n-2))
         tempai = (tempar*y+tempai*x)/(float(2*n-2))
         tempar = tempbr
         tempbr = (float(n))
         b(1,n) = tempar*(1.e0-sign*tempcr/tempbr)+tempai*tempci/tempbr
         b(2,n) = tempai*(1.e0-sign*tempcr/tempbr)-tempar*tempci/tempbr
  137 continue
  138 return
c
c revision history---
c
c october 1978     first added to nssl
c november 1978    changed the value of the machine dependent constant
c                  nten from 322 to 293 to correct an undetected
c                  underflow and subsequent division of 0 by 0 when
c                  besir was called with large n (greater than 140).
c-----------------------------------------------------------------------
      end
c
c uliber     from portlib                                  12/27/80
      subroutine uliber (ierr,messg,nmessg)
c
c dimension of           messg(1+(nmessg-1)/ncpwd), where ncpwd is the
c arguments              number of characters that can be stored in one
c                        integer word.
c
c latest revision        april 1977.
c
c purpose                prints an error message.
c
c usage                  call uliber (ierr,messg,nmessg)
c
c arguments
c
c on input               ierr
c                          error number.  if ierr .lt. 32, the error is
c                          considered to be non-fatal and uliber returns
c                          after printing the error message.  if ierr
c                          .ge. 32 the error is considered fatal, and
c                          uliber stops after printing the message.
c                        messg
c                          the error message to be printed.
c                        nmessg
c                          the length of the message, in characters.
c
      dimension messg(1)
      integer erunit,prunit
c
c erunit should be set to the local unit number for error messages.
c
      data erunit/6/,prunit/6/
c
c      if (erunit .eq. 0) write(prunit,1000)
c
c 1000 format(50h1uliber, a subroutine to print error messages, has/
c     1       50h been called, but no local implementation of      /
c     2       50h uliber has been provided.  to properly implement /
c     3       50h this subroutine for the local machine and        /
c     4       50h environment, please see the comments in uliber.  /)
c
c replace the if statement and format statement above with the following
c code where $ncpwd should be replaced with the number of characters
c that can be stored in one integer word, and $n should be replaced by
c the value of 1+(79/$ncpwd).
c
       mm=1+(nmessg-1)/8
       write(erunit,1000) ierr,(messg(i),i=1,mm)
1000   format(' ****error #' ,i5,25h,error message follows.../
     1       (18 a8 ))
c
   10 if (ierr .ge. 32) stop
      return
      end
c
c**********************************************************************
c
      function bessi(n,x)

      implicit none

      integer n, iacc
      real bessi, x, bigno, bigni
      parameter (iacc = 40, bigno = 1.0e10, bigni = 1.0e-10)
c     Uses bessi0
c     Returns the modified Bessel function In(x) for any real x and n.ge.2
      integer j, m
      real bi, bim, bip, tox, bessi0
      if (n .lt. 2) pause 'bad argument n in bessi'
      if (x .eq. 0.) then
         bessi = 0.
      else
         tox = 2.0/abs(x)
         bip = 0.0
         bi = 1.0
         bessi = 0.
         m = 2 * ((n + int(sqrt(float(iacc * n)))))
         do j = m, 1, -1
            bim = bip + float(j) * tox * bi
            bip = bi
            bi = bim
            if (abs(bi) .gt. bigno) then
               bessi = bessi * bigni
               bi = bi * bigni
               bip = bip * bigni
            endif
            if (j .eq. n) bessi = bip
         enddo
         bessi = bessi * bessi0(x) / bi
         if(x .lt. 0. .and. mod(n,2) .eq. 1) bessi = -bessi
      endif
      return
      end
c
c**********************************************************************
c
      function bessi0(x)

      implicit none

      real bessi0, x
c      Returns the modified Bessel function I0(x) for any real x
      real ax
      double precision p1, p2, p3, p4, p5, p6, p7,
     1                 q1, q2, q3, q4, q5, q6, q7, q8, q9, y
      save  p1, p2, p3, p4, p5, p6, p7,
     1      q1, q2, q3, q4, q5, q6, q7, q8, q9

      data p1, p2, p3, p4, p5, p6, p7 / 1.0d0, 3.5156229d0, 3.0899424d0,
     1   1.2067492d0, 0.2659732d0, 0.360768d-1, 0.45813d-2 /

      data q1, q2, q3, q4, q5, q6, q7, q8, q9/0.39894228d0,0.1328592d-1,
     1   0.225319d-2,-0.157565d-2, 0.916281d-2, -0.2057706d-1,
     1   0.2635537d-1, -0.1647633d-1, 0.392377d-2 /

      if (abs(x) .lt. 3.75) then
         y = (x / 3.75)**2
         bessi0 = p1 + y * (p2+y*(p3+y*(p4+y*(p5+y*(p6+y*p7)))))
      else
         ax = abs(x)
         y = 3.75 / ax
         bessi0 = (exp(ax) / sqrt(ax)) * (q1+y*(q2+y*(q3+y*(q4
     1      +y*(q5+y*(q6+y*(q7+y*(q8+y*q9))))))))
      endif
      return
      end
c
c**********************************************************************
c
      function bessi1(x)

      implicit none

      real bessi1, x
c      Returns the modified Bessel function I1(x) for any real x
      real ax
      double precision p1, p2, p3, p4, p5, p6, p7,
     1                 q1, q2, q3, q4, q5, q6, q7, q8, q9, y
      save  p1, p2, p3, p4, p5, p6, p7,
     1      q1, q2, q3, q4, q5, q6, q7, q8, q9

      data p1, p2, p3, p4, p5, p6, p7 / 0.5d0,0.87890594d0,0.51498869d0,
     1   0.15084934d0, 0.2658733d-1, 0.301532d-2, 0.32411d-3 /

      data q1, q2, q3, q4, q5, q6, q7, q8, q9/0.39894228d0,-0.398802d-1,
     1   -0.362018d-2,0.163801d-2,-0.1031555d-1, 0.2282967d-1,
     1   -0.2895312d-1, 0.1787654d-1, -0.420059d-2 /

      if (abs(x) .lt. 3.75) then
         y = (x / 3.75)**2
         bessi1 = x * (p1+y*(p2+y*(p3+y*(p4+y*(p5+y*(p6+y*p7))))))
      else
         ax = abs(x)
         y = 3.75 / ax
         bessi1 = (exp(ax) / sqrt(ax)) * (q1+y*(q2+y*(q3+y*(q4
     1      +y*(q5+y*(q6+y*(q7+y*(q8+y*q9))))))))
      endif
      return
      end

c
c***************************************************************************
c

      function bessk0 (x)

      implicit none

      real bessk0, x
c--uses bessi0
c--returns the modified Bessel function Ko(x) for any positive real x
      real bessi0
      doubleprecision p1, p2, p3, p4, p5, p6, p7
      doubleprecision q1, q2, q3, q4, q5, q6, q7, y
c--accumulate polynomials in double precision
      save p1,p2,p3,p4,p5,p6,p7,q1,q2,q3,q4,q5,q6,q7
      data p1,p2,p3,p4,p5,p6,p7/-0.57721566D0,0.42278420D0,
     1   0.23069756D0,0.3488590D-1,0.262698D-2,0.10750D-3,0.74D-5/
      data q1,q2,q3,q4,q5,q6,q7/1.25331414D0,-0.7832358D-1,0.2189568D-1,
     1   -0.1062446D-1,0.587872D-2,-0.251540D-2,0.53208D-3/
      if (x .lt. 2.0) then
c  Polynomial fit.
         y = x*x/4.0
         bessk0 =(-log(x/2.0)*bessi0(x))+(p1+y*(p2+y*(p3+
     *               y*(p4+y*(p5+y*(p6+y*p7))))))
      else
         y = (2.0/x)
         bessk0=(exp(-x)/sqrt(x))*(q1+y*(q2+y*(q3+
     *          y*(q4+ y*(q5+y*(q6+y*q7))))))
      endif
      return
      end
c
c***************************************************************************
c

      function bessk1 (x)

      implicit none

      real bessk1, x
c--uses bessi1
c--returns the modified Bessel function K1(x) for any positive real x
      real bessi1
      doubleprecision p1, p2, p3, p4, p5, p6, p7
      doubleprecision q1, q2, q3, q4, q5, q6, q7, y
c--accumulate polynomials in double precision
      save p1,p2,p3,p4,p5,p6,p7,q1,q2,q3,q4,q5,q6,q7
      data p1,p2,p3,p4,p5,p6,p7/1.0D0,0.15443144D0,-0.67278579D0,
     1  -0.18156897D0,-0.1919402D-1,-0.110404D-2,-0.4686D-4/
      data q1,q2,q3,q4,q5,q6,q7/1.25331414D0,0.23498619D0,-0.3655620D-1,
     1   0.1504268D-1,-0.780353D-2,0.325614D-2,-0.68245D-3/
      if (x .lt. 2.0) then
c  Polynomial fit.
         y = x*x/4.0
         bessk1 =(log(x/2.0)*bessi1(x))+(1.0/x)*(p1+y*(p2+
     *         y*(p3+y*(p4+y*(p5+y*(p6+y*p7))))))
      else
         y = 2.0/x
         bessk1=(exp(-x)/sqrt(x))*(q1+y*(q2+y*(q3+
     *          y*(q4+ y*(q5+y*(q6+y*q7))))))
      endif
      return
      end

c
c**********************************************************************
c
      function factrl(n)
      integer n
      real factrl
*------------------------------------------------------
*     uses gammln
*     returns the value of n! as a floating point number
*-------------------------------------------------------

      integer j, ntop
      real a(33), gammln
      save ntop, a
      data ntop, a(1)/0, 1./
      if(n .lt. 0) then
         pause 'negative factorial in factrl'
      else if (n .le. ntop)then
         factrl = a(n+1)
      else if (n .le. 32) then
         do j = ntop+1, n
            a(j+1) = j * a(j)
         end do
         ntop = n
         factrl = a(n+1)
      else
         factrl = exp(gammln(n+1.))
      end if

      return
      end

c
c*****************************************************************
c
      function gammln(xx)
      real gammln, xx
c         Returns the value ln(gamma(xx)) for xx > 0.
      integer j
      double precision ser, stp, tmp, x, y, cof(6)
c     internal arithmetic will be done in double precision,
c     a nicety that you can omit if five figure accuracy is good enough
      save cof, stp
      data cof, stp/76.18009172947146d0,-86.50532032941677d0,
     .   24.01409824083091d0,-1.231739572450155d0,.1208650973866179d-2,
     .   -.5395239384953d-5,2.5066282746310005d0/
      x = xx
      y = x
      tmp = x + 5.5d0
      tmp = (x + 0.5d0) * log(tmp) - tmp
      ser=1.000000000190015d0
      do j = 1, 6
         y = y + 1.d0
         ser = ser + cof(j) / y
      end do
      gammln = tmp + log(stp * ser / x)
      return
      end


MODULE kinematics
USE global
CONTAINS
  FUNCTION cscalarprod(p1,p2)
    IMPLICIT NONE
    COMPLEX(KIND(1d0))::cscalarprod
    COMPLEX(KIND(1d0)),DIMENSION(0:3),INTENT(IN)::p1,p2
!    REAL(KIND(1d0)),PARAMETER::EPS2=1d-6
!    REAL(KIND(1d0))::max
    cscalarprod=p1(0)*p2(0)-p1(1)*p2(1)-p1(2)*p2(2)-p1(3)*p2(3)
!    max=ABS(p1(0)*p2(0))+ABS(p1(1)*p2(1))+ABS(p1(2)*p2(2))+ABS(p1(3)*p2(3))
!    IF(ABS(cscalarprod/max).LT.EPS2)cscalarprod=DCMPLX(0d0)
  END FUNCTION cscalarprod

  FUNCTION scalarprod(p1,p2)
    IMPLICIT NONE
    REAL(KIND(1d0))::scalarprod
    REAL(KIND(1d0)),DIMENSION(0:3),INTENT(IN)::p1,p2
!    REAL(KIND(1d0)),PARAMETER::EPS2=1d-6
!    REAL(KIND(1d0))::max
    scalarprod=p1(0)*p2(0)-p1(1)*p2(1)-p1(2)*p2(2)-p1(3)*p2(3)
    IF(check.OR.ONSHELL_IREGI)THEN
       CALL makeonshell(nmass,massref(1:nmass),scalarprod)
!    ELSE
!       IF(ABS(scalarprod/mu_R_IREGI**2).LT.1d-6)scalarprod=0d0
    ENDIF
!    max=ABS(p1(0)*p2(0))+ABS(p1(1)*p2(1))+ABS(p1(2)*p2(2))+ABS(p1(3)*p2(3))
!    IF(ABS(scalarprod/max).LT.EPS2)scalarprod=0d0
  END FUNCTION scalarprod

 ! this is the ad-hoc function only for testing
  SUBROUTINE makeonshell(n,mt2,ma)
    IMPLICIT NONE
    INTEGER,INTENT(IN)::n
    REAL(KIND(1d0)),INTENT(INOUT)::ma
    REAL(KIND(1d0)),DIMENSION(n),INTENT(IN)::mt2
    INTEGER::i
    IF(n.GT.0)THEN
       IF(ABS(ma/mt2(1)).LT.ZEROTHR_IREGI)THEN
          ma=0d0
          RETURN
       ENDIF
       DO i=1,n
          IF(ABS(ma-mt2(i))/mt2(i).LT.ZEROTHR_IREGI)THEN
             ma=mt2(i)
             RETURN
          ENDIF
       ENDDO
    ELSE
       IF(ABS(ma).LT.1d-3)THEN
          ma=0d0
          RETURN
       ENDIF
    ENDIF
    RETURN
  END SUBROUTINE makeonshell
END MODULE kinematics


      subroutine tmultr(trans,trans1,n)
      implicit none
      integer*4 n
      real*8,intent(inout):: trans(6,n)
      real*8 ,intent(in)::trans1(6,6)
c the warning generated by gfortran up tp 10 is said to be a bug in gcc....
      trans=matmul(trans1,trans)
c      do 10 i=1,n
c$$$        v1=trans(1,:)
c$$$        v2=trans(2,:)
c$$$        v3=trans(3,:)
c$$$        v4=trans(4,:)
c$$$        v5=trans(5,:)
c$$$        v6=trans(6,:)
c$$$        trans(1,:)=trans1(1,1)*v1+trans1(1,2)*v2+trans1(1,3)*v3
c$$$     1              +trans1(1,4)*v4+trans1(1,5)*v5+trans1(1,6)*v6
c$$$        trans(2,:)=trans1(2,1)*v1+trans1(2,2)*v2+trans1(2,3)*v3
c$$$     1              +trans1(2,4)*v4+trans1(2,5)*v5+trans1(2,6)*v6
c$$$        trans(3,:)=trans1(3,1)*v1+trans1(3,2)*v2+trans1(3,3)*v3
c$$$     1              +trans1(3,4)*v4+trans1(3,5)*v5+trans1(3,6)*v6
c$$$        trans(4,:)=trans1(4,1)*v1+trans1(4,2)*v2+trans1(4,3)*v3
c$$$     1              +trans1(4,4)*v4+trans1(4,5)*v5+trans1(4,6)*v6
c$$$        trans(5,:)=trans1(5,1)*v1+trans1(5,2)*v2+trans1(5,3)*v3
c$$$     1              +trans1(5,4)*v4+trans1(5,5)*v5+trans1(5,6)*v6
c$$$        trans(6,:)=trans1(6,1)*v1+trans1(6,2)*v2+trans1(6,3)*v3
c$$$     1              +trans1(6,4)*v4+trans1(6,5)*v5+trans1(6,6)*v6
c10    continue
      return
      end

      subroutine tmultr5(trans,trans1,n)
      implicit none
      integer*4 n
      real*8 , intent(inout) ::trans(6,n)
      real*8 , intent(in)::trans1(6,6)
      real*8 v1(n),v2(n),v3(n),v4(n),v6(n)
c     if(trans1(1,5) .ne. 0.d0
c     $     .or. trans1(2,5) .ne. 0.d0
c     $     .or. trans1(3,5) .ne. 0.d0
c     $     .or. trans1(4,5) .ne. 0.d0
c     $     .or. trans1(5,5) .ne. 1.d0)then
c     write(*,*)trans(6,1000000)
c     endif
      v1=trans(1,:)
      v2=trans(2,:)
      v3=trans(3,:)
      v4=trans(4,:)
      v6=trans(6,:)
      trans(1,:)=trans1(1,1)*v1+trans1(1,2)*v2+trans1(1,3)*v3
     1     +trans1(1,4)*v4+trans1(1,6)*v6
      trans(2,:)=trans1(2,1)*v1+trans1(2,2)*v2+trans1(2,3)*v3
     1     +trans1(2,4)*v4+trans1(2,6)*v6
      trans(3,:)=trans1(3,1)*v1+trans1(3,2)*v2+trans1(3,3)*v3
     1     +trans1(3,4)*v4+trans1(3,6)*v6
      trans(4,:)=trans1(4,1)*v1+trans1(4,2)*v2+trans1(4,3)*v3
     1     +trans1(4,4)*v4+trans1(4,6)*v6
      trans(5,:)=trans1(5,1)*v1+trans1(5,2)*v2+trans1(5,3)*v3
     1     +trans1(5,4)*v4+trans(5,:)+trans1(5,6)*v6
      return
      end


      subroutine Saxpar
c
c     + + + PURPOSE + + +
c
c     Estimate Saxton&Rawl equation parameters for a soil
c
c     Called from: SR WINIT
c     Author(s): Shuhui Dun, WSU
c     Reference in User Guide: Saxton K.E. and Rawls W.J., 2006.
c     Soil water characteristics estimates by texture and organic matter for hydraologic solution.
c     Soil SCI. SOC. AM. J., 70, 1569--1578
c
c     Version: 2008.
c     Date recoded: Febuary 19, 2008
c     Verified by: Joan Wu, WSU
c

c
c
c     + + + KEYWORDS + + +
c
c     + + + PARAMETERS + + +
      include 'pmxpln.inc'
      include 'pmxnsl.inc'
      include 'pmxelm.inc'
c
c     + + + ARGUMENT DECLARATIONS + + +
c
c
c     + + + ARGUMENT DEFINITIONS + + +
c
c
c     + + + COMMON BLOCKS + + +
c
      include 'cstruc.inc'
c     Read: iplane
      include 'cwater.inc'
c      read: nsl(iplane)
      include 'csolva1.inc'
c
      include 'csaxp.inc'
c     Modify: parameters for van Genuchten equation
c
c
c     + + + LOCAL VARIABLES + + +
c
      integer i
      real sw1500, sw33, sws33, s33, spaen, tsaxwp
c
c     + + + LOCAL DEFINITIONS + + +
c
c     sw1500: first solution 1500 kpa soil moisture
c     sw33: first solution 1500 kpa soil moisture
c     sws33:first solution SAT-33 kpa soil moisture
c     s33:  moisture SAT-33 kpa, normal density
c      spaen: first solution air entry tension, kpa
c
c     + + + SAVES + + +
c
c     + + + SUBROUTINES CALLED + + +
c
c
c     + + + DATA INITIALIZATIONS + + +
c
c     + + + END SPECIFICATIONS + + +
c
      do 10 i = 1, nsl(iplane)
c      eqation 1
         sw1500 = - 0.024*sand(i,iplane)
     1            + 0.487*clay(i,iplane)
     1            + 0.006*orgmat(i,iplane)
     1            + 0.005*sand(i,iplane)*orgmat(i,iplane)
     1            - 0.013*clay(i,iplane)*orgmat(i,iplane)
     1            + 0.068*sand(i,iplane)*clay(i,iplane)
     1            + 0.031
c
          saxwp(i,iplane) = sw1500 + 0.14*sw1500 - 0.02
c
c      equation 2
         sw33 =   - 0.251*sand(i,iplane)
     1            + 0.195*clay(i,iplane)
     1            + 0.011*orgmat(i,iplane)
     1            + 0.006*sand(i,iplane)*orgmat(i,iplane)
     1            - 0.027*clay(i,iplane)*orgmat(i,iplane)
     1            + 0.452*sand(i,iplane)*clay(i,iplane)
     1            + 0.299
c
          saxfc(i,iplane) = sw33 + 1.283*sw33**2 - 0.374*sw33 - 0.015
c
c      equation 3
         sws33 =  + 0.278*sand(i,iplane)
     1            + 0.034*clay(i,iplane)
     1            + 0.022*orgmat(i,iplane)
     1            - 0.018*sand(i,iplane)*orgmat(i,iplane)
     1            - 0.027*clay(i,iplane)*orgmat(i,iplane)
     1            - 0.584*sand(i,iplane)*clay(i,iplane)
     1            + 0.078
c
          s33 = sws33 + 0.636*sws33 - 0.107
c
c      eqation 4
          spaen =  - 21.67*sand(i,iplane)
     1            - 27.93*clay(i,iplane)
     1            - 81.97*s33
     1            + 71.12*sand(i,iplane)*s33
     1            +  8.29*clay(i,iplane)*s33
     1            + 14.05*sand(i,iplane)*clay(i,iplane)
     1            + 27.16
c
          saxenp(i,iplane) = spaen + 0.02*spaen**2 - 0.113*spaen - 0.70
c
c     equation 5
          saxpor(i,iplane) = saxfc(i,iplane) + s33
     1                       - 0.097*sand(i,iplane) + 0.043
c
c     eqation 14 and 15
c     check for saxwp above 0 so that log function is valid, will go negative above about
c     98% sand. 12-22-09 jrf
c
           if (saxwp(i,iplane).gt.0.0) then
              tsaxwp = saxwp(i,iplane)
           else
              tsaxwp = 1.0e-16
           endif
            saxB(i,iplane) = (log(1500.) - log(33.))/
     1                     (log(saxfc(i,iplane)) - log(tsaxwp))
            saxA(i,iplane) = exp (log(33.) +
     1                          saxB(i,iplane)*log(saxfc(i,iplane)))
c
c     equation 16
c     The unit of the original saxton ans Rawls is mm/hr.
c     The factor 1./3.6e+6 converts mm/hr to m/s
          saxks(i,iplane) = 1930.*(saxpor(i,iplane) - saxfc(i,iplane))
     1                      **(3. - 1./saxB(i,iplane))*1.0/3.6E+6
10    continue
c
      return
      end


	SUBROUTINE VMATRIX2(DATA,N1,N2)
C
C	CALCULATES VARIANCE MATRIX AND EIGENVALUES, USING DATA VALUES
C	FROM 1 TO N1, AND N2 TO 2048, WORKS ON 2 VALUES, I.E. TDSF
C
C	COMMON /PARTBLK/ XDATA(2050,4),XFDATA(2050,4),XGSE(2050,4),
C     1		XRE,YRE,ZRE,SUNCLOCK,SPINRATE,SPSS
	common /headblk/ major,minor,s_scet,nsys
	COMMON /VARMATX/ EVAL(2),EVECT(2,2)
	REAL DATA(2050,4),DATAS(2050,3),VMAT(2,2)
	REAL WT(2048)
	integer*4	s_scet(2)
	INTEGER*4 SUNCLOCK
C
C	CALCULATE WEIGHTS, TO ELIMINATE BZGLITCH
C
C	WRITE(79,*) ' '
C	WRITE(79,*) 'IN VMATRIX, N1,N2',N1,N2
C
	DO N = 1,2048
	  WT(N) = 1.
	ENDDO
C	IF(N2-N1.LT.90) THEN
C	  WRITE(79,*) 'VARIANCE MATRIX FOR SAMPLES EXCEPT',N1,' TO',N2
C	  DO N = N1,N2
C	    WT(N) = 0.
C	  ENDDO
C	ELSE
C	  WRITE(79,*) 'VARIANCE MATRIX FOR ALL SAMPLES '
C	ENDIF
C
C	subtract averages
C
	DO M = 1,2
	  AV(M) = 0.
	  DO N = 1,2048
		AV(M) = AV(M) + WT(N)*DATA(N,M)
	  ENDDO
	  AV(M) = AV(M)/(N2-N1+1)
	ENDDO
	DO M = 1,2
	  DO N = 1,2048
		DATAS(N,M) = DATA(N,M) - AV(M)
	  ENDDO
	ENDDO
C
C	PRINT*,' WITH AVERAGES REMOVED'
C
C	FORM VARIANCE MATRIX
C
	DO K = 1,3
	  DO M = 1,3
		VMAT(K,M) = 0.
	  ENDDO
	ENDDO
C
	DO N = 1,2048
	  DO K = 1,2
	    DO M = 1,2
		VMAT(K,M) = VMAT(K,M) + WT(N)*DATAS(N,K)*DATAS(N,M)
	    ENDDO
	  ENDDO
	ENDDO
C
	DO K = 1,2
	  DO M = 1,2
		VMAT(K,M) = VMAT(K,M)/(N2-N1+1)
	  ENDDO
	ENDDO
	print*,'diag elems',vmat(1,1),vmat(2,2),vmat(3,3),
     1	' trace',vmat(1,1)+vmat(2,2)+vmat(3,3)
C
C	CALCULATE EIGENVALUES AND MATRIX OF EIGENVECTORS
C
	CALL JACOBI(VMAT,2,2,EVAL,EVECT,NROT)
C	PRINT*,'EIGENVALUES',EVAL
C	PRINT*,'EIGENVECTOR'
C	PRINT*,(EVECT(1,I),I=1,3)
C	PRINT*,(EVECT(2,I),I=1,3)
C	PRINT*,(EVECT(3,I),I=1,3)
C
C	SORT IN DESCENDING ORDER OF EIGENVALUES
C
	CALL EIGSRT(EVAL,EVECT,2,2)
C
C
C 	ENFORCE A RIGHT HANDED SYSTEM BY REVERSING THE SMALLEST
C	EIGENVECTOR IF NECESSARY
C
C	ADOTBXC = EVECT(1,1)*EVECT(2,2)*EVECT(3,3)
C     1	 - EVECT(1,1)*EVECT(3,2)*EVECT(2,3)
C     1	 + EVECT(2,1)*EVECT(1,3)*EVECT(3,2)
C     1	 - EVECT(2,1)*EVECT(1,2)*EVECT(3,3)
C     1	 + EVECT(3,1)*EVECT(1,2)*EVECT(2,3)
C     1	 - EVECT(3,1)*EVECT(2,2)*EVECT(1,3)
C	PRINT*,'DETERMINANT OF EIGENVECTORS',ADOTBXC
C	IF(ADOTBXC.LT.0.) THEN        ! REVERSE SMALLEST EVECT FOR RH SYSTEM
C	  EVECT(1,3) = -EVECT(1,3)
C	  EVECT(2,3) = -EVECT(2,3)
C	  EVECT(3,3) = -EVECT(3,3)
C	ENDIF
C
	PRINT*,'IN SYSTEM',NSYS,'  EIGENVALUES:'
	PRINT*,EVAL,' sum',eval(1)+eval(2)+eval(3)
	PRINT*,'EIGENVECTORS'
	PRINT*,(EVECT(1,I),I=1,2)
	PRINT*,(EVECT(2,I),I=1,2)
C	PRINT*,(EVECT(3,I),I=1,3)
	WRITE(79,*) 'IN SYSTEM',NSYS,'  EIGENVALUES:'
	WRITE(79,*)  EVAL
	WRITE(79,*) 'EIGENVECTORS IN COLUMNS BELOW EIGENVALUES'
	WRITE(79,*)(EVECT(1,I),I=1,2)
	WRITE(79,*)(EVECT(2,I),I=1,2)
C	WRITE(79,*)(EVECT(3,I),I=1,3)
	NSYS = 2
	RETURN
	END


!
! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
! See https://llvm.org/LICENSE.txt for license information.
! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
!

! Check that the type order between the declaration of "pure function" and its implementation
! doesnt produce a compilation error
! Test related to fix for issue #1016

module pureFunction
  implicit none
  private
  public :: func, other_func
  type :: foo
    integer :: mydim
  end type

contains

subroutine func(tparam, oparam)
  integer, intent(in) :: tparam
  integer, dimension(other_func(tparam, 10)), intent(out), optional :: oparam

  oparam = 42
end subroutine

pure function other_func(tparam, idim)
  integer, intent(in) :: tparam
  integer, intent(in) :: idim
  integer :: other_func

  other_func = min(tparam, idim)
end function

end module

program testPureFunction
	use pureFunction
	implicit none

	integer :: result(1)
	integer :: expect
	integer :: param1

	param1 = 20
	call func(param1,result)
	expect = 42

	call check(result, expect, 1)
	print *,result, expect, param1

end program


module setup_manufacsol_mod

    use constants_mod
    use setup_config_mod
    use equations_const_mod

contains

pure function init_manufacsol(x,y,z) result(u)

    real(dp), intent(in)    :: x,y,z
    real(dp)                :: u(N_VARS)

    u(DENS_VAR) = d0 + d1*Sin((2*Pi*df1*x)/L) + d2*Cos((2*Pi*df2*y)/L) + d3*Sin((2*Pi*df3*z)/L) + d4*Cos((2*Pi*df4*x*y*z)/L**3);
    u(MOMX_VAR) = u0 + u1*Cos((2*Pi*uf1*x)/L) + u2*Sin((2*Pi*uf2*y)/L) + u3*Cos((2*Pi*uf3*z)/L) + u4*Sin((2*Pi*uf4*x*y*z)/L**3);
    u(MOMY_VAR) = v0 + v1*Sin((2*Pi*vf1*x)/L) + v2*Cos((2*Pi*vf2*y)/L) + v3*Sin((2*Pi*vf3*z)/L) + v4*Cos((2*Pi*vf4*x*y*z)/L**3);
    ! u(MOMZ_VAR) = w0 + w1*Cos((2*Pi*wf1*x)/L) + w2*Sin((2*Pi*wf2*y)/L) + w3*Cos((2*Pi*wf3*z)/L) + w4*Sin((2*Pi*wf4*x*y*z)/L**3);
    u(ENER_VAR) = p0 + p1*Sin((2*Pi*pf1*x)/L) + p2*Cos((2*Pi*pf2*y)/L) + p3*Sin((2*Pi*pf3*z)/L) + p4*Sin((2*Pi*pf4*x*y*z)/L**3);

end function

pure function calc_manufacsol(x,y,z) result(r)

    real(dp), intent(in)    :: x,y,z
    real(dp)                :: r(N_VARS)

    r = 0.0

    !! F function

    r(DENS_VAR) = r(DENS_VAR) + &
        ((2*Pi*u4*uf4*y*z*Cos((2*Pi*uf4*x*y*z)/L**3))/L**3 - (2*Pi*u1*uf1*Sin((2*Pi*uf1*x)/L))/L)*(d0 + d2*Cos((2*df2*Pi*y)/L) + d4*Cos((2*df4*Pi*x*y*z)/L**3) + d1*Sin((2*df1*Pi*x)/L) + d3*Sin((2*df3*Pi*z)/L)) + &
        &  ((2*d1*df1*Pi*Cos((2*df1*Pi*x)/L))/L - (2*d4*df4*Pi*y*z*Sin((2*df4*Pi*x*y*z)/L**3))/L**3)*(u0 + u1*Cos((2*Pi*uf1*x)/L) + u3*Cos((2*Pi*uf3*z)/L) + u2*Sin((2*Pi*uf2*y)/L) + u4*Sin((2*Pi*uf4*x*y*z)/L**3));

    r(MOMX_VAR) = r(MOMX_VAR) + &
        & (2*p1*pf1*Pi*Cos((2*pf1*Pi*x)/L))/L + (2*p4*pf4*Pi*y*z*Cos((2*pf4*Pi*x*y*z)/L**3))/L**3 + &
        & 2*((2*Pi*u4*uf4*y*z*Cos((2*Pi*uf4*x*y*z)/L**3))/L**3 - (2*Pi*u1*uf1*Sin((2*Pi*uf1*x)/L))/L)*(d0 + d2*Cos((2*df2*Pi*y)/L) + d4*Cos((2*df4*Pi*x*y*z)/L**3) + d1*Sin((2*df1*Pi*x)/L) + d3*Sin((2*df3*Pi*z)/L))* &
        &  (u0 + u1*Cos((2*Pi*uf1*x)/L) + u3*Cos((2*Pi*uf3*z)/L) + u2*Sin((2*Pi*uf2*y)/L) + u4*Sin((2*Pi*uf4*x*y*z)/L**3)) + &
        & ((2*d1*df1*Pi*Cos((2*df1*Pi*x)/L))/L - (2*d4*df4*Pi*y*z*Sin((2*df4*Pi*x*y*z)/L**3))/L**3)*(u0 + u1*Cos((2*Pi*uf1*x)/L) + u3*Cos((2*Pi*uf3*z)/L) + u2*Sin((2*Pi*uf2*y)/L) + u4*Sin((2*Pi*uf4*x*y*z)/L**3))**2;

    r(MOMY_VAR) = r(MOMY_VAR) + &
        & ((2*Pi*u4*uf4*y*z*Cos((2*Pi*uf4*x*y*z)/L**3))/L**3 - (2*Pi*u1*uf1*Sin((2*Pi*uf1*x)/L))/L)*(d0 + d2*Cos((2*df2*Pi*y)/L) + d4*Cos((2*df4*Pi*x*y*z)/L**3) + d1*Sin((2*df1*Pi*x)/L) + d3*Sin((2*df3*Pi*z)/L))* &
        &  (v0 + v2*Cos((2*Pi*vf2*y)/L) + v4*Cos((2*Pi*vf4*x*y*z)/L**3) + v1*Sin((2*Pi*vf1*x)/L) + v3*Sin((2*Pi*vf3*z)/L)) + &
        & (v0 + v2*Cos((2*Pi*vf2*y)/L) + v4*Cos((2*Pi*vf4*x*y*z)/L**3) + v1*Sin((2*Pi*vf1*x)/L) + v3*Sin((2*Pi*vf3*z)/L))*((2*d1*df1*Pi*Cos((2*df1*Pi*x)/L))/L - (2*d4*df4*Pi*y*z*Sin((2*df4*Pi*x*y*z)/L**3))/L**3)* &
        &  (u0 + u1*Cos((2*Pi*uf1*x)/L) + u3*Cos((2*Pi*uf3*z)/L) + u2*Sin((2*Pi*uf2*y)/L) + u4*Sin((2*Pi*uf4*x*y*z)/L**3)) + &
        & (d0 + d2*Cos((2*df2*Pi*y)/L) + d4*Cos((2*df4*Pi*x*y*z)/L**3) + d1*Sin((2*df1*Pi*x)/L) + d3*Sin((2*df3*Pi*z)/L))* &
        &  (u0 + u1*Cos((2*Pi*uf1*x)/L) + u3*Cos((2*Pi*uf3*z)/L) + u2*Sin((2*Pi*uf2*y)/L) + u4*Sin((2*Pi*uf4*x*y*z)/L**3))*((2*Pi*v1*vf1*Cos((2*Pi*vf1*x)/L))/L - (2*Pi*v4*vf4*y*z*Sin((2*Pi*vf4*x*y*z)/L**3))/L**3);

    ! r(MOMZ_VAR) = r(MOMZ_VAR) + &
    !     & ((2*Pi*w4*wf4*y*z*Cos((2*Pi*wf4*x*y*z)/L**3))/L**3 - (2*Pi*w1*wf1*Sin((2*Pi*wf1*x)/L))/L)*(d0 + d2*Cos((2*df2*Pi*y)/L) + d4*Cos((2*df4*Pi*x*y*z)/L**3) + d1*Sin((2*df1*Pi*x)/L) + d3*Sin((2*df3*Pi*z)/L))* &
    !     &  (u0 + u1*Cos((2*Pi*uf1*x)/L) + u3*Cos((2*Pi*uf3*z)/L) + u2*Sin((2*Pi*uf2*y)/L) + u4*Sin((2*Pi*uf4*x*y*z)/L**3)) + &
    !     & ((2*Pi*u4*uf4*y*z*Cos((2*Pi*uf4*x*y*z)/L**3))/L**3 - (2*Pi*u1*uf1*Sin((2*Pi*uf1*x)/L))/L)*(d0 + d2*Cos((2*df2*Pi*y)/L) + d4*Cos((2*df4*Pi*x*y*z)/L**3) + d1*Sin((2*df1*Pi*x)/L) + d3*Sin((2*df3*Pi*z)/L))* &
    !     &  (w0 + w1*Cos((2*Pi*wf1*x)/L) + w3*Cos((2*Pi*wf3*z)/L) + w2*Sin((2*Pi*wf2*y)/L) + w4*Sin((2*Pi*wf4*x*y*z)/L**3)) + &
    !     & ((2*d1*df1*Pi*Cos((2*df1*Pi*x)/L))/L - (2*d4*df4*Pi*y*z*Sin((2*df4*Pi*x*y*z)/L**3))/L**3)*(u0 + u1*Cos((2*Pi*uf1*x)/L) + u3*Cos((2*Pi*uf3*z)/L) + u2*Sin((2*Pi*uf2*y)/L) + u4*Sin((2*Pi*uf4*x*y*z)/L**3))* &
    !     &  (w0 + w1*Cos((2*Pi*wf1*x)/L) + w3*Cos((2*Pi*wf3*z)/L) + w2*Sin((2*Pi*wf2*y)/L) + w4*Sin((2*Pi*wf4*x*y*z)/L**3));

    r(ENER_VAR) = r(ENER_VAR) + &
        & ((2*Pi*u4*uf4*y*z*Cos((2*Pi*uf4*x*y*z)/L**3))/L**3 - (2*Pi*u1*uf1*Sin((2*Pi*uf1*x)/L))/L)* &
        &    (p0 + p2*Cos((2*pf2*Pi*y)/L) + p1*Sin((2*pf1*Pi*x)/L) + p3*Sin((2*pf3*Pi*z)/L) + p4*Sin((2*pf4*Pi*x*y*z)/L**3) +  &
        &      (p0 + p2*Cos((2*pf2*Pi*y)/L) + p1*Sin((2*pf1*Pi*x)/L) + p3*Sin((2*pf3*Pi*z)/L) + p4*Sin((2*pf4*Pi*x*y*z)/L**3))/(-1 + kappa) +  &
        &      ((d0 + d2*Cos((2*df2*Pi*y)/L) + d4*Cos((2*df4*Pi*x*y*z)/L**3) + d1*Sin((2*df1*Pi*x)/L) + d3*Sin((2*df3*Pi*z)/L))*&
        &         ((v0 + v2*Cos((2*Pi*vf2*y)/L) + v4*Cos((2*Pi*vf4*x*y*z)/L**3) + v1*Sin((2*Pi*vf1*x)/L) + v3*Sin((2*Pi*vf3*z)/L))**2 +  &
        &           (u0 + u1*Cos((2*Pi*uf1*x)/L) + u3*Cos((2*Pi*uf3*z)/L) + u2*Sin((2*Pi*uf2*y)/L) + u4*Sin((2*Pi*uf4*x*y*z)/L**3))**2 +  &
        &           (w0 + w1*Cos((2*Pi*wf1*x)/L) + w3*Cos((2*Pi*wf3*z)/L) + w2*Sin((2*Pi*wf2*y)/L) + w4*Sin((2*Pi*wf4*x*y*z)/L**3))**2))/2.) +  &
        &   (u0 + u1*Cos((2*Pi*uf1*x)/L) + u3*Cos((2*Pi*uf3*z)/L) + u2*Sin((2*Pi*uf2*y)/L) + u4*Sin((2*Pi*uf4*x*y*z)/L**3))*&
        &    ((2*p1*pf1*Pi*Cos((2*pf1*Pi*x)/L))/L + (2*p4*pf4*Pi*y*z*Cos((2*pf4*Pi*x*y*z)/L**3))/L**3 + ((2*p1*pf1*Pi*Cos((2*pf1*Pi*x)/L))/L + (2*p4*pf4*Pi*y*z*Cos((2*pf4*Pi*x*y*z)/L**3))/L**3)/(-1 + kappa) +  &
        &      ((d0 + d2*Cos((2*df2*Pi*y)/L) + d4*Cos((2*df4*Pi*x*y*z)/L**3) + d1*Sin((2*df1*Pi*x)/L) + d3*Sin((2*df3*Pi*z)/L))*&
        &         (2*((2*Pi*u4*uf4*y*z*Cos((2*Pi*uf4*x*y*z)/L**3))/L**3 - (2*Pi*u1*uf1*Sin((2*Pi*uf1*x)/L))/L)*&
        &            (u0 + u1*Cos((2*Pi*uf1*x)/L) + u3*Cos((2*Pi*uf3*z)/L) + u2*Sin((2*Pi*uf2*y)/L) + u4*Sin((2*Pi*uf4*x*y*z)/L**3)) +  &
        &           2*(v0 + v2*Cos((2*Pi*vf2*y)/L) + v4*Cos((2*Pi*vf4*x*y*z)/L**3) + v1*Sin((2*Pi*vf1*x)/L) + v3*Sin((2*Pi*vf3*z)/L))*&
        &            ((2*Pi*v1*vf1*Cos((2*Pi*vf1*x)/L))/L - (2*Pi*v4*vf4*y*z*Sin((2*Pi*vf4*x*y*z)/L**3))/L**3) +  &
        &           2*((2*Pi*w4*wf4*y*z*Cos((2*Pi*wf4*x*y*z)/L**3))/L**3 - (2*Pi*w1*wf1*Sin((2*Pi*wf1*x)/L))/L)*&
        &            (w0 + w1*Cos((2*Pi*wf1*x)/L) + w3*Cos((2*Pi*wf3*z)/L) + w2*Sin((2*Pi*wf2*y)/L) + w4*Sin((2*Pi*wf4*x*y*z)/L**3))))/2. +  &
        &      (((2*d1*df1*Pi*Cos((2*df1*Pi*x)/L))/L - (2*d4*df4*Pi*y*z*Sin((2*df4*Pi*x*y*z)/L**3))/L**3)*&
        &         ((v0 + v2*Cos((2*Pi*vf2*y)/L) + v4*Cos((2*Pi*vf4*x*y*z)/L**3) + v1*Sin((2*Pi*vf1*x)/L) + v3*Sin((2*Pi*vf3*z)/L))**2 +  &
        &           (u0 + u1*Cos((2*Pi*uf1*x)/L) + u3*Cos((2*Pi*uf3*z)/L) + u2*Sin((2*Pi*uf2*y)/L) + u4*Sin((2*Pi*uf4*x*y*z)/L**3))**2 +  &
        &           (w0 + w1*Cos((2*Pi*wf1*x)/L) + w3*Cos((2*Pi*wf3*z)/L) + w2*Sin((2*Pi*wf2*y)/L) + w4*Sin((2*Pi*wf4*x*y*z)/L**3))**2))/2.);

    !! G function

    r(DENS_VAR) = r(DENS_VAR) + &
         & (v0 + v2*Cos((2*Pi*vf2*y)/L) + v4*Cos((2*Pi*vf4*x*y*z)/L**3) + v1*Sin((2*Pi*vf1*x)/L) + v3*Sin((2*Pi*vf3*z)/L))*((-2*d2*df2*Pi*Sin((2*df2*Pi*y)/L))/L - (2*d4*df4*Pi*x*z*Sin((2*df4*Pi*x*y*z)/L**3))/L**3) + &
         & (d0 + d2*Cos((2*df2*Pi*y)/L) + d4*Cos((2*df4*Pi*x*y*z)/L**3) + d1*Sin((2*df1*Pi*x)/L) + d3*Sin((2*df3*Pi*z)/L))*((-2*Pi*v2*vf2*Sin((2*Pi*vf2*y)/L))/L - (2*Pi*v4*vf4*x*z*Sin((2*Pi*vf4*x*y*z)/L**3))/L**3);

    r(MOMX_VAR) = r(MOMX_VAR) + &
        & ((2*Pi*u2*uf2*Cos((2*Pi*uf2*y)/L))/L + (2*Pi*u4*uf4*x*z*Cos((2*Pi*uf4*x*y*z)/L**3))/L**3)*(d0 + d2*Cos((2*df2*Pi*y)/L) + d4*Cos((2*df4*Pi*x*y*z)/L**3) + d1*Sin((2*df1*Pi*x)/L) + d3*Sin((2*df3*Pi*z)/L))*&
        &   (v0 + v2*Cos((2*Pi*vf2*y)/L) + v4*Cos((2*Pi*vf4*x*y*z)/L**3) + v1*Sin((2*Pi*vf1*x)/L) + v3*Sin((2*Pi*vf3*z)/L)) + &
        &  (v0 + v2*Cos((2*Pi*vf2*y)/L) + v4*Cos((2*Pi*vf4*x*y*z)/L**3) + v1*Sin((2*Pi*vf1*x)/L) + v3*Sin((2*Pi*vf3*z)/L))*((-2*d2*df2*Pi*Sin((2*df2*Pi*y)/L))/L - (2*d4*df4*Pi*x*z*Sin((2*df4*Pi*x*y*z)/L**3))/L**3)*&
        &   (u0 + u1*Cos((2*Pi*uf1*x)/L) + u3*Cos((2*Pi*uf3*z)/L) + u2*Sin((2*Pi*uf2*y)/L) + u4*Sin((2*Pi*uf4*x*y*z)/L**3)) + &
        &  (d0 + d2*Cos((2*df2*Pi*y)/L) + d4*Cos((2*df4*Pi*x*y*z)/L**3) + d1*Sin((2*df1*Pi*x)/L) + d3*Sin((2*df3*Pi*z)/L))*&
        &   (u0 + u1*Cos((2*Pi*uf1*x)/L) + u3*Cos((2*Pi*uf3*z)/L) + u2*Sin((2*Pi*uf2*y)/L) + u4*Sin((2*Pi*uf4*x*y*z)/L**3))*((-2*Pi*v2*vf2*Sin((2*Pi*vf2*y)/L))/L - (2*Pi*v4*vf4*x*z*Sin((2*Pi*vf4*x*y*z)/L**3))/L**3);

    r(MOMY_VAR) = r(MOMY_VAR) + &
        & (2*p4*pf4*Pi*x*z*Cos((2*pf4*Pi*x*y*z)/L**3))/L**3 - (2*p2*pf2*Pi*Sin((2*pf2*Pi*y)/L))/L + &
        &  (v0 + v2*Cos((2*Pi*vf2*y)/L) + v4*Cos((2*Pi*vf4*x*y*z)/L**3) + v1*Sin((2*Pi*vf1*x)/L) + v3*Sin((2*Pi*vf3*z)/L))**2*&
        &   ((-2*d2*df2*Pi*Sin((2*df2*Pi*y)/L))/L - (2*d4*df4*Pi*x*z*Sin((2*df4*Pi*x*y*z)/L**3))/L**3) + &
        &  2*(d0 + d2*Cos((2*df2*Pi*y)/L) + d4*Cos((2*df4*Pi*x*y*z)/L**3) + d1*Sin((2*df1*Pi*x)/L) + d3*Sin((2*df3*Pi*z)/L))*&
        &   (v0 + v2*Cos((2*Pi*vf2*y)/L) + v4*Cos((2*Pi*vf4*x*y*z)/L**3) + v1*Sin((2*Pi*vf1*x)/L) + v3*Sin((2*Pi*vf3*z)/L))*((-2*Pi*v2*vf2*Sin((2*Pi*vf2*y)/L))/L - (2*Pi*v4*vf4*x*z*Sin((2*Pi*vf4*x*y*z)/L**3))/L**3);

    ! r(MOMZ_VAR) = r(MOMZ_VAR) + &
    !     & ((2*Pi*w2*wf2*Cos((2*Pi*wf2*y)/L))/L + (2*Pi*w4*wf4*x*z*Cos((2*Pi*wf4*x*y*z)/L**3))/L**3)*(d0 + d2*Cos((2*df2*Pi*y)/L) + d4*Cos((2*df4*Pi*x*y*z)/L**3) + d1*Sin((2*df1*Pi*x)/L) + d3*Sin((2*df3*Pi*z)/L))*&
    !     &  (v0 + v2*Cos((2*Pi*vf2*y)/L) + v4*Cos((2*Pi*vf4*x*y*z)/L**3) + v1*Sin((2*Pi*vf1*x)/L) + v3*Sin((2*Pi*vf3*z)/L)) + &
    !     & (v0 + v2*Cos((2*Pi*vf2*y)/L) + v4*Cos((2*Pi*vf4*x*y*z)/L**3) + v1*Sin((2*Pi*vf1*x)/L) + v3*Sin((2*Pi*vf3*z)/L))*((-2*d2*df2*Pi*Sin((2*df2*Pi*y)/L))/L - (2*d4*df4*Pi*x*z*Sin((2*df4*Pi*x*y*z)/L**3))/L**3)*&
    !     &  (w0 + w1*Cos((2*Pi*wf1*x)/L) + w3*Cos((2*Pi*wf3*z)/L) + w2*Sin((2*Pi*wf2*y)/L) + w4*Sin((2*Pi*wf4*x*y*z)/L**3)) + &
    !     & (d0 + d2*Cos((2*df2*Pi*y)/L) + d4*Cos((2*df4*Pi*x*y*z)/L**3) + d1*Sin((2*df1*Pi*x)/L) + d3*Sin((2*df3*Pi*z)/L))*((-2*Pi*v2*vf2*Sin((2*Pi*vf2*y)/L))/L - (2*Pi*v4*vf4*x*z*Sin((2*Pi*vf4*x*y*z)/L**3))/L**3)*&
    !     &  (w0 + w1*Cos((2*Pi*wf1*x)/L) + w3*Cos((2*Pi*wf3*z)/L) + w2*Sin((2*Pi*wf2*y)/L) + w4*Sin((2*Pi*wf4*x*y*z)/L**3));

    r(ENER_VAR) = r(ENER_VAR) + &
        & ((-2*Pi*v2*vf2*Sin((2*Pi*vf2*y)/L))/L - (2*Pi*v4*vf4*x*z*Sin((2*Pi*vf4*x*y*z)/L**3))/L**3)*&
        &  (p0 + p2*Cos((2*pf2*Pi*y)/L) + p1*Sin((2*pf1*Pi*x)/L) + p3*Sin((2*pf3*Pi*z)/L) + p4*Sin((2*pf4*Pi*x*y*z)/L**3) + &
        &    (p0 + p2*Cos((2*pf2*Pi*y)/L) + p1*Sin((2*pf1*Pi*x)/L) + p3*Sin((2*pf3*Pi*z)/L) + p4*Sin((2*pf4*Pi*x*y*z)/L**3))/(-1 + kappa) + &
        &    ((d0 + d2*Cos((2*df2*Pi*y)/L) + d4*Cos((2*df4*Pi*x*y*z)/L**3) + d1*Sin((2*df1*Pi*x)/L) + d3*Sin((2*df3*Pi*z)/L))*&
        &       ((v0 + v2*Cos((2*Pi*vf2*y)/L) + v4*Cos((2*Pi*vf4*x*y*z)/L**3) + v1*Sin((2*Pi*vf1*x)/L) + v3*Sin((2*Pi*vf3*z)/L))**2 + &
        &         (u0 + u1*Cos((2*Pi*uf1*x)/L) + u3*Cos((2*Pi*uf3*z)/L) + u2*Sin((2*Pi*uf2*y)/L) + u4*Sin((2*Pi*uf4*x*y*z)/L**3))**2 + &
        &         (w0 + w1*Cos((2*Pi*wf1*x)/L) + w3*Cos((2*Pi*wf3*z)/L) + w2*Sin((2*Pi*wf2*y)/L) + w4*Sin((2*Pi*wf4*x*y*z)/L**3))**2))/2.) + &
        & (v0 + v2*Cos((2*Pi*vf2*y)/L) + v4*Cos((2*Pi*vf4*x*y*z)/L**3) + v1*Sin((2*Pi*vf1*x)/L) + v3*Sin((2*Pi*vf3*z)/L))*&
        &  ((2*p4*pf4*Pi*x*z*Cos((2*pf4*Pi*x*y*z)/L**3))/L**3 - (2*p2*pf2*Pi*Sin((2*pf2*Pi*y)/L))/L + ((2*p4*pf4*Pi*x*z*Cos((2*pf4*Pi*x*y*z)/L**3))/L**3 - (2*p2*pf2*Pi*Sin((2*pf2*Pi*y)/L))/L)/(-1 + kappa) + &
        &    ((d0 + d2*Cos((2*df2*Pi*y)/L) + d4*Cos((2*df4*Pi*x*y*z)/L**3) + d1*Sin((2*df1*Pi*x)/L) + d3*Sin((2*df3*Pi*z)/L))*&
        &       (2*((2*Pi*u2*uf2*Cos((2*Pi*uf2*y)/L))/L + (2*Pi*u4*uf4*x*z*Cos((2*Pi*uf4*x*y*z)/L**3))/L**3)*&
        &          (u0 + u1*Cos((2*Pi*uf1*x)/L) + u3*Cos((2*Pi*uf3*z)/L) + u2*Sin((2*Pi*uf2*y)/L) + u4*Sin((2*Pi*uf4*x*y*z)/L**3)) + &
        &         2*(v0 + v2*Cos((2*Pi*vf2*y)/L) + v4*Cos((2*Pi*vf4*x*y*z)/L**3) + v1*Sin((2*Pi*vf1*x)/L) + v3*Sin((2*Pi*vf3*z)/L))*&
        &          ((-2*Pi*v2*vf2*Sin((2*Pi*vf2*y)/L))/L - (2*Pi*v4*vf4*x*z*Sin((2*Pi*vf4*x*y*z)/L**3))/L**3) + &
        &         2*((2*Pi*w2*wf2*Cos((2*Pi*wf2*y)/L))/L + (2*Pi*w4*wf4*x*z*Cos((2*Pi*wf4*x*y*z)/L**3))/L**3)*&
        &          (w0 + w1*Cos((2*Pi*wf1*x)/L) + w3*Cos((2*Pi*wf3*z)/L) + w2*Sin((2*Pi*wf2*y)/L) + w4*Sin((2*Pi*wf4*x*y*z)/L**3))))/2. + &
        &    (((-2*d2*df2*Pi*Sin((2*df2*Pi*y)/L))/L - (2*d4*df4*Pi*x*z*Sin((2*df4*Pi*x*y*z)/L**3))/L**3)*&
        &       ((v0 + v2*Cos((2*Pi*vf2*y)/L) + v4*Cos((2*Pi*vf4*x*y*z)/L**3) + v1*Sin((2*Pi*vf1*x)/L) + v3*Sin((2*Pi*vf3*z)/L))**2 + &
        &         (u0 + u1*Cos((2*Pi*uf1*x)/L) + u3*Cos((2*Pi*uf3*z)/L) + u2*Sin((2*Pi*uf2*y)/L) + u4*Sin((2*Pi*uf4*x*y*z)/L**3))**2 + &
        &         (w0 + w1*Cos((2*Pi*wf1*x)/L) + w3*Cos((2*Pi*wf3*z)/L) + w2*Sin((2*Pi*wf2*y)/L) + w4*Sin((2*Pi*wf4*x*y*z)/L**3))**2))/2.);

    !! H function
    r(DENS_VAR) = r(DENS_VAR) + &
        & (d0 + d2*Cos((2*df2*Pi*y)/L) + d4*Cos((2*df4*Pi*x*y*z)/L**3) + d1*Sin((2*df1*Pi*x)/L) + d3*Sin((2*df3*Pi*z)/L))*((2*Pi*w4*wf4*x*y*Cos((2*Pi*wf4*x*y*z)/L**3))/L**3 - (2*Pi*w3*wf3*Sin((2*Pi*wf3*z)/L))/L) + &
        & ((2*d3*df3*Pi*Cos((2*df3*Pi*z)/L))/L - (2*d4*df4*Pi*x*y*Sin((2*df4*Pi*x*y*z)/L**3))/L**3)*(w0 + w1*Cos((2*Pi*wf1*x)/L) + w3*Cos((2*Pi*wf3*z)/L) + w2*Sin((2*Pi*wf2*y)/L) + w4*Sin((2*Pi*wf4*x*y*z)/L**3));

    r(MOMX_VAR) = r(MOMX_VAR) + &
        & (d0 + d2*Cos((2*df2*Pi*y)/L) + d4*Cos((2*df4*Pi*x*y*z)/L**3) + d1*Sin((2*df1*Pi*x)/L) + d3*Sin((2*df3*Pi*z)/L))*((2*Pi*w4*wf4*x*y*Cos((2*Pi*wf4*x*y*z)/L**3))/L**3 - (2*Pi*w3*wf3*Sin((2*Pi*wf3*z)/L))/L)*&
        &  (u0 + u1*Cos((2*Pi*uf1*x)/L) + u3*Cos((2*Pi*uf3*z)/L) + u2*Sin((2*Pi*uf2*y)/L) + u4*Sin((2*Pi*uf4*x*y*z)/L**3)) + &
        & (d0 + d2*Cos((2*df2*Pi*y)/L) + d4*Cos((2*df4*Pi*x*y*z)/L**3) + d1*Sin((2*df1*Pi*x)/L) + d3*Sin((2*df3*Pi*z)/L))*((2*Pi*u4*uf4*x*y*Cos((2*Pi*uf4*x*y*z)/L**3))/L**3 - (2*Pi*u3*uf3*Sin((2*Pi*uf3*z)/L))/L)*&
        &  (w0 + w1*Cos((2*Pi*wf1*x)/L) + w3*Cos((2*Pi*wf3*z)/L) + w2*Sin((2*Pi*wf2*y)/L) + w4*Sin((2*Pi*wf4*x*y*z)/L**3)) + &
        & ((2*d3*df3*Pi*Cos((2*df3*Pi*z)/L))/L - (2*d4*df4*Pi*x*y*Sin((2*df4*Pi*x*y*z)/L**3))/L**3)*(u0 + u1*Cos((2*Pi*uf1*x)/L) + u3*Cos((2*Pi*uf3*z)/L) + u2*Sin((2*Pi*uf2*y)/L) + u4*Sin((2*Pi*uf4*x*y*z)/L**3))*&
        &  (w0 + w1*Cos((2*Pi*wf1*x)/L) + w3*Cos((2*Pi*wf3*z)/L) + w2*Sin((2*Pi*wf2*y)/L) + w4*Sin((2*Pi*wf4*x*y*z)/L**3));

    r(MOMY_VAR) = r(MOMY_VAR) + &
        & (d0 + d2*Cos((2*df2*Pi*y)/L) + d4*Cos((2*df4*Pi*x*y*z)/L**3) + d1*Sin((2*df1*Pi*x)/L) + d3*Sin((2*df3*Pi*z)/L))*&
        &  (v0 + v2*Cos((2*Pi*vf2*y)/L) + v4*Cos((2*Pi*vf4*x*y*z)/L**3) + v1*Sin((2*Pi*vf1*x)/L) + v3*Sin((2*Pi*vf3*z)/L))*((2*Pi*w4*wf4*x*y*Cos((2*Pi*wf4*x*y*z)/L**3))/L**3 - (2*Pi*w3*wf3*Sin((2*Pi*wf3*z)/L))/L) + &
        & (v0 + v2*Cos((2*Pi*vf2*y)/L) + v4*Cos((2*Pi*vf4*x*y*z)/L**3) + v1*Sin((2*Pi*vf1*x)/L) + v3*Sin((2*Pi*vf3*z)/L))*((2*d3*df3*Pi*Cos((2*df3*Pi*z)/L))/L - (2*d4*df4*Pi*x*y*Sin((2*df4*Pi*x*y*z)/L**3))/L**3)*&
        &  (w0 + w1*Cos((2*Pi*wf1*x)/L) + w3*Cos((2*Pi*wf3*z)/L) + w2*Sin((2*Pi*wf2*y)/L) + w4*Sin((2*Pi*wf4*x*y*z)/L**3)) + &
        & (d0 + d2*Cos((2*df2*Pi*y)/L) + d4*Cos((2*df4*Pi*x*y*z)/L**3) + d1*Sin((2*df1*Pi*x)/L) + d3*Sin((2*df3*Pi*z)/L))*((2*Pi*v3*vf3*Cos((2*Pi*vf3*z)/L))/L - (2*Pi*v4*vf4*x*y*Sin((2*Pi*vf4*x*y*z)/L**3))/L**3)*&
        &  (w0 + w1*Cos((2*Pi*wf1*x)/L) + w3*Cos((2*Pi*wf3*z)/L) + w2*Sin((2*Pi*wf2*y)/L) + w4*Sin((2*Pi*wf4*x*y*z)/L**3));

    ! r(MOMZ_VAR) = r(MOMZ_VAR) + &
    !     & (2*p3*pf3*Pi*Cos((2*pf3*Pi*z)/L))/L + (2*p4*pf4*Pi*x*y*Cos((2*pf4*Pi*x*y*z)/L**3))/L**3 + &
    !     &  2*(d0 + d2*Cos((2*df2*Pi*y)/L) + d4*Cos((2*df4*Pi*x*y*z)/L**3) + d1*Sin((2*df1*Pi*x)/L) + d3*Sin((2*df3*Pi*z)/L))*((2*Pi*w4*wf4*x*y*Cos((2*Pi*wf4*x*y*z)/L**3))/L**3 - (2*Pi*w3*wf3*Sin((2*Pi*wf3*z)/L))/L)*&
    !     &   (w0 + w1*Cos((2*Pi*wf1*x)/L) + w3*Cos((2*Pi*wf3*z)/L) + w2*Sin((2*Pi*wf2*y)/L) + w4*Sin((2*Pi*wf4*x*y*z)/L**3)) + &
    !     &  ((2*d3*df3*Pi*Cos((2*df3*Pi*z)/L))/L - (2*d4*df4*Pi*x*y*Sin((2*df4*Pi*x*y*z)/L**3))/L**3)*(w0 + w1*Cos((2*Pi*wf1*x)/L) + w3*Cos((2*Pi*wf3*z)/L) + w2*Sin((2*Pi*wf2*y)/L) + w4*Sin((2*Pi*wf4*x*y*z)/L**3))**2;

    r(ENER_VAR) = r(ENER_VAR) + &
        & ((2*Pi*w4*wf4*x*y*Cos((2*Pi*wf4*x*y*z)/L**3))/L**3 - (2*Pi*w3*wf3*Sin((2*Pi*wf3*z)/L))/L)*&
        &  (p0 + p2*Cos((2*pf2*Pi*y)/L) + p1*Sin((2*pf1*Pi*x)/L) + p3*Sin((2*pf3*Pi*z)/L) + p4*Sin((2*pf4*Pi*x*y*z)/L**3) + &
        &    (p0 + p2*Cos((2*pf2*Pi*y)/L) + p1*Sin((2*pf1*Pi*x)/L) + p3*Sin((2*pf3*Pi*z)/L) + p4*Sin((2*pf4*Pi*x*y*z)/L**3))/(-1 + kappa) + &
        &    ((d0 + d2*Cos((2*df2*Pi*y)/L) + d4*Cos((2*df4*Pi*x*y*z)/L**3) + d1*Sin((2*df1*Pi*x)/L) + d3*Sin((2*df3*Pi*z)/L))*&
        &       ((v0 + v2*Cos((2*Pi*vf2*y)/L) + v4*Cos((2*Pi*vf4*x*y*z)/L**3) + v1*Sin((2*Pi*vf1*x)/L) + v3*Sin((2*Pi*vf3*z)/L))**2 + &
        &         (u0 + u1*Cos((2*Pi*uf1*x)/L) + u3*Cos((2*Pi*uf3*z)/L) + u2*Sin((2*Pi*uf2*y)/L) + u4*Sin((2*Pi*uf4*x*y*z)/L**3))**2 + &
        &         (w0 + w1*Cos((2*Pi*wf1*x)/L) + w3*Cos((2*Pi*wf3*z)/L) + w2*Sin((2*Pi*wf2*y)/L) + w4*Sin((2*Pi*wf4*x*y*z)/L**3))**2))/2.) + &
        & (w0 + w1*Cos((2*Pi*wf1*x)/L) + w3*Cos((2*Pi*wf3*z)/L) + w2*Sin((2*Pi*wf2*y)/L) + w4*Sin((2*Pi*wf4*x*y*z)/L**3))*&
        &  ((2*p3*pf3*Pi*Cos((2*pf3*Pi*z)/L))/L + (2*p4*pf4*Pi*x*y*Cos((2*pf4*Pi*x*y*z)/L**3))/L**3 + ((2*p3*pf3*Pi*Cos((2*pf3*Pi*z)/L))/L + (2*p4*pf4*Pi*x*y*Cos((2*pf4*Pi*x*y*z)/L**3))/L**3)/(-1 + kappa) + &
        &    ((d0 + d2*Cos((2*df2*Pi*y)/L) + d4*Cos((2*df4*Pi*x*y*z)/L**3) + d1*Sin((2*df1*Pi*x)/L) + d3*Sin((2*df3*Pi*z)/L))*&
        &       (2*((2*Pi*u4*uf4*x*y*Cos((2*Pi*uf4*x*y*z)/L**3))/L**3 - (2*Pi*u3*uf3*Sin((2*Pi*uf3*z)/L))/L)*&
        &          (u0 + u1*Cos((2*Pi*uf1*x)/L) + u3*Cos((2*Pi*uf3*z)/L) + u2*Sin((2*Pi*uf2*y)/L) + u4*Sin((2*Pi*uf4*x*y*z)/L**3)) + &
        &         2*(v0 + v2*Cos((2*Pi*vf2*y)/L) + v4*Cos((2*Pi*vf4*x*y*z)/L**3) + v1*Sin((2*Pi*vf1*x)/L) + v3*Sin((2*Pi*vf3*z)/L))*&
        &          ((2*Pi*v3*vf3*Cos((2*Pi*vf3*z)/L))/L - (2*Pi*v4*vf4*x*y*Sin((2*Pi*vf4*x*y*z)/L**3))/L**3) + &
        &         2*((2*Pi*w4*wf4*x*y*Cos((2*Pi*wf4*x*y*z)/L**3))/L**3 - (2*Pi*w3*wf3*Sin((2*Pi*wf3*z)/L))/L)*&
        &          (w0 + w1*Cos((2*Pi*wf1*x)/L) + w3*Cos((2*Pi*wf3*z)/L) + w2*Sin((2*Pi*wf2*y)/L) + w4*Sin((2*Pi*wf4*x*y*z)/L**3))))/2. + &
        &    (((2*d3*df3*Pi*Cos((2*df3*Pi*z)/L))/L - (2*d4*df4*Pi*x*y*Sin((2*df4*Pi*x*y*z)/L**3))/L**3)*&
        &       ((v0 + v2*Cos((2*Pi*vf2*y)/L) + v4*Cos((2*Pi*vf4*x*y*z)/L**3) + v1*Sin((2*Pi*vf1*x)/L) + v3*Sin((2*Pi*vf3*z)/L))**2 + &
        &         (u0 + u1*Cos((2*Pi*uf1*x)/L) + u3*Cos((2*Pi*uf3*z)/L) + u2*Sin((2*Pi*uf2*y)/L) + u4*Sin((2*Pi*uf4*x*y*z)/L**3))**2 + &
        &         (w0 + w1*Cos((2*Pi*wf1*x)/L) + w3*Cos((2*Pi*wf3*z)/L) + w2*Sin((2*Pi*wf2*y)/L) + w4*Sin((2*Pi*wf4*x*y*z)/L**3))**2))/2.);

end function

end module


      SUBROUTINE FB01TD( JOBX, MULTRC, N, M, P, SINV, LDSINV, AINV,
     $                   LDAINV, AINVB, LDAINB, RINV, LDRINV, C, LDC,
     $                   QINV, LDQINV, X, RINVY, Z, E, TOL, IWORK,
     $                   DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To calculate a combined measurement and time update of one
C     iteration of the time-invariant Kalman filter. This update is
C     given for the square root information filter, using the condensed
C     controller Hessenberg form.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOBX    CHARACTER*1
C             Indicates whether X    is to be computed as follows:
C                                i+1
C             = 'X':  X    is computed and stored in array X;
C                      i+1
C             = 'N':  X    is not required.
C                      i+1
C
C     MULTRC  CHARACTER*1             -1/2
C             Indicates how matrices R     and C    are to be passed to
C                                     i+1       i+1
C             the routine as follows:
C             = 'P':  Array RINV is not used and the array C must
C                                          -1/2
C                     contain the product R    C   ;
C                                          i+1  i+1
C             = 'N':  Arrays RINV and C must contain the matrices
C                     as described below.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The actual state dimension, i.e., the order of the
C                       -1      -1
C             matrices S   and A  .  N >= 0.
C                       i
C
C     M       (input) INTEGER
C             The actual input dimension, i.e., the order of the matrix
C              -1/2
C             Q    .  M >= 0.
C              i
C
C     P       (input) INTEGER
C             The actual output dimension, i.e., the order of the matrix
C              -1/2
C             R    .  P >= 0.
C              i+1
C
C     SINV    (input/output) DOUBLE PRECISION array, dimension
C             (LDSINV,N)
C             On entry, the leading N-by-N upper triangular part of this
C                                 -1
C             array must contain S  , the inverse of the square root
C                                 i
C             (right Cholesky factor) of the state covariance matrix
C             P    (hence the information square root) at instant i.
C              i|i
C             On exit, the leading N-by-N upper triangular part of this
C                             -1
C             array contains S   , the inverse of the square root (right
C                             i+1
C             Cholesky factor) of the state covariance matrix P
C                                                              i+1|i+1
C             (hence the information square root) at instant i+1.
C             The strict lower triangular part of this array is not
C             referenced.
C
C     LDSINV  INTEGER
C             The leading dimension of array SINV.  LDSINV >= MAX(1,N).
C
C     AINV    (input) DOUBLE PRECISION array, dimension (LDAINV,N)
C                                                                 -1
C             The leading N-by-N part of this array must contain A  ,
C             the inverse of the state transition matrix of the discrete
C             system in controller Hessenberg form (e.g., as produced by
C             SLICOT Library Routine TB01MD).
C
C     LDAINV  INTEGER
C             The leading dimension of array AINV.  LDAINV >= MAX(1,N).
C
C     AINVB   (input) DOUBLE PRECISION array, dimension (LDAINB,M)
C                                                                  -1
C             The leading N-by-M part of this array must contain  A  B,
C                             -1
C             the product of A   and the input weight matrix B of the
C             discrete system, in upper controller Hessenberg form
C             (e.g., as produced by SLICOT Library Routine TB01MD).
C
C     LDAINB  INTEGER
C             The leading dimension of array AINVB.  LDAINB >= MAX(1,N).
C
C     RINV    (input) DOUBLE PRECISION array, dimension (LDRINV,*)
C             If MULTRC = 'N', then the leading P-by-P upper triangular
C                                              -1/2
C             part of this array must contain R    , the inverse of the
C                                              i+1
C             covariance square root (right Cholesky factor) of the
C             output (measurement) noise (hence the information square
C             root) at instant i+1.
C             The strict lower triangular part of this array is not
C             referenced.
C             Otherwise, RINV is not referenced and can be supplied as a
C             dummy array (i.e., set parameter LDRINV = 1 and declare
C             this array to be RINV(1,1) in the calling program).
C
C     LDRINV  INTEGER
C             The leading dimension of array RINV.
C             LDRINV >= MAX(1,P) if MULTRC = 'N';
C             LDRINV >= 1        if MULTRC = 'P'.
C
C     C       (input) DOUBLE PRECISION array, dimension (LDC,N)
C             The leading P-by-N part of this array must contain C   ,
C                                                       -1/2      i+1
C             the output weight matrix (or the product R    C    if
C                                                       i+1  i+1
C             MULTRC = 'P') of the discrete system at instant i+1.
C
C     LDC     INTEGER
C             The leading dimension of array C.  LDC >= MAX(1,P).
C
C     QINV    (input/output) DOUBLE PRECISION array, dimension
C             (LDQINV,M)
C             On entry, the leading M-by-M upper triangular part of this
C                                 -1/2
C             array must contain Q    , the inverse of the covariance
C                                 i
C             square root (right Cholesky factor) of the input (process)
C             noise (hence the information square root) at instant i.
C             On exit, the leading M-by-M upper triangular part of this
C                                    -1/2
C             array contains (QINOV )    , the inverse of the covariance
C                                  i
C             square root (right Cholesky factor) of the process noise
C             innovation (hence the information square root) at
C             instant i.
C             The strict lower triangular part of this array is not
C             referenced.
C
C     LDQINV  INTEGER
C             The leading dimension of array QINV.  LDQINV >= MAX(1,M).
C
C     X       (input/output) DOUBLE PRECISION array, dimension (N)
C             On entry, this array must contain X , the estimated
C                                                i
C             filtered state at instant i.
C             On exit, if JOBX = 'X', and INFO = 0, then this array
C             contains X   , the estimated filtered state at
C                       i+1
C             instant i+1.
C             On exit, if JOBX = 'N', or JOBX = 'X' and INFO = 1, then
C                                  -1
C             this array contains S   X   .
C                                  i+1 i+1
C
C     RINVY   (input) DOUBLE PRECISION array, dimension (P)
C                                      -1/2
C             This array must contain R    Y   , the product of the
C                                      i+1  i+1
C                                      -1/2
C             upper triangular matrix R     and the measured output
C                                      i+1
C             vector Y    at instant i+1.
C                     i+1
C
C     Z       (input) DOUBLE PRECISION array, dimension (M)
C             This array must contain Z , the mean value of the state
C                                      i
C             process noise at instant i.
C
C     E       (output) DOUBLE PRECISION array, dimension (P)
C             This array contains E   , the estimated error at instant
C                                  i+1
C             i+1.
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             If JOBX = 'X', then TOL is used to test for near
C                                        -1
C             singularity of the matrix S   . If the user sets
C                                        i+1
C             TOL > 0, then the given value of TOL is used as a
C             lower bound for the reciprocal condition number of that
C             matrix; a matrix whose estimated condition number is less
C             than 1/TOL is considered to be nonsingular. If the user
C             sets TOL <= 0, then an implicitly computed, default
C             tolerance, defined by TOLDEF = N*N*EPS, is used instead,
C             where EPS is the machine precision (see LAPACK Library
C             routine DLAMCH).
C             Otherwise, TOL is not referenced.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (LIWORK)
C             where LIWORK = N if JOBX = 'X',
C             and   LIWORK = 1 otherwise.
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal value
C             of LDWORK.  If INFO = 0 and JOBX = 'X', DWORK(2) returns
C             an estimate of the reciprocal of the condition number
C                                 -1
C             (in the 1-norm) of S   .
C                                 i+1
C
C     LDWORK  The length of the array DWORK.
C             LDWORK >= MAX(1,N*(N+2*M)+3*M,(N+P)*(N+1)+N+MAX(N-1,M+1)),
C                                 if JOBX = 'N';
C             LDWORK >= MAX(2,N*(N+2*M)+3*M,(N+P)*(N+1)+N+MAX(N-1,M+1),
C                           3*N), if JOBX = 'X'.
C             For optimum performance LDWORK should be larger.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;                        -1
C             = 1:  if JOBX = 'X' and the matrix S    is singular,
C                                                 i+1       -1
C                   i.e., the condition number estimate of S    (in the
C                                                           i+1
C                                                         -1    -1/2
C                   1-norm) exceeds 1/TOL.  The matrices S   , Q
C                                                         i+1   i
C                   and E have been computed.
C
C     METHOD
C
C     The routine performs one recursion of the square root information
C     filter algorithm, summarized as follows:
C
C       |    -1/2             -1/2    |     |         -1/2             |
C       |   Q         0      Q    Z   |     | (QINOV )     *     *     |
C       |    i                i    i  |     |       i                  |
C       |                             |     |                          |
C       |           -1/2      -1/2    |     |             -1    -1     |
C     T |    0     R    C    R    Y   |  =  |    0       S     S   X   |
C       |           i+1  i+1  i+1  i+1|     |             i+1   i+1 i+1|
C       |                             |     |                          |
C       |  -1 -1     -1 -1    -1      |     |                          |
C       | S  A  B   S  A     S  X     |     |    0         0     E     |
C       |  i         i        i  i    |     |                     i+1  |
C
C                   (Pre-array)                      (Post-array)
C
C     where T is an orthogonal transformation triangularizing the
C                        -1/2
C     pre-array, (QINOV )     is the inverse of the covariance square
C                      i
C     root (right Cholesky factor) of the process noise innovation
C                                                            -1  -1
C     (hence the information square root) at instant i and (A  ,A  B) is
C     in upper controller Hessenberg form.
C
C     An example of the pre-array is given below (where N = 6, M = 2,
C     and P = 3):
C
C         |x x |             | x|
C         |  x |             | x|
C         _______________________
C         |    | x x x x x x | x|
C         |    | x x x x x x | x|
C         |    | x x x x x x | x|
C         _______________________
C         |x x | x x x x x x | x|
C         |  x | x x x x x x | x|
C         |    | x x x x x x | x|
C         |    |   x x x x x | x|
C         |    |     x x x x | x|
C         |    |       x x x | x|
C
C     The inverse of the corresponding state covariance matrix P
C                                                               i+1|i+1
C     (hence the information matrix I) is then factorized as
C
C                    -1         -1     -1
C         I       = P       = (S   )' S
C          i+1|i+1   i+1|i+1    i+1    i+1
C
C     and one combined time and measurement update for the state is
C     given by X   .
C               i+1
C
C     The triangularization is done entirely via Householder
C     transformations exploiting the zero pattern of the pre-array.
C
C     REFERENCES
C
C     [1] Anderson, B.D.O. and Moore, J.B.
C         Optimal Filtering.
C         Prentice Hall, Englewood Cliffs, New Jersey, 1979.
C
C     [2] Van Dooren, P. and Verhaegen, M.H.G.
C         Condensed Forms for Efficient Time-Invariant Kalman Filtering.
C         SIAM J. Sci. Stat. Comp., 9. pp. 516-530, 1988.
C
C     [3] Verhaegen, M.H.G. and Van Dooren, P.
C         Numerical Aspects of Different Kalman Filter Implementations.
C         IEEE Trans. Auto. Contr., AC-31, pp. 907-917, Oct. 1986.
C
C     [4] Vanbegin, M., Van Dooren, P., and Verhaegen, M.H.G.
C         Algorithm 675: FORTRAN Subroutines for Computing the Square
C         Root Covariance Filter and Square Root Information Filter in
C         Dense or Hessenberg Forms.
C         ACM Trans. Math. Software, 15, pp. 243-256, 1989.
C
C     NUMERICAL ASPECTS
C
C     The algorithm requires approximately
C
C           3    2                           2          3
C     (1/6)N  + N x (3/2 x M + P) + 2 x N x M  + 2/3 x M
C
C     operations and is backward stable (see [3]).
C
C     CONTRIBUTORS
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997.
C     Supersedes Release 2.0 routine FB01HD by M. Vanbegin,
C     P. Van Dooren, and M.H.G. Verhaegen.
C
C     REVISIONS
C
C     February 20, 1998, November 20, 2003, February 14, 2004.
C
C     KEYWORDS
C
C     Controller Hessenberg form, Kalman filtering, optimal filtering,
C     orthogonal transformation, recursive estimation, square-root
C     filtering, square-root information filtering.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ONE, TWO
      PARAMETER         ( ONE = 1.0D0, TWO = 2.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         JOBX, MULTRC
      INTEGER           INFO, LDAINB, LDAINV, LDC, LDQINV, LDRINV,
     $                  LDSINV, LDWORK, M, N, P
      DOUBLE PRECISION  TOL
C     .. Array Arguments ..
      INTEGER           IWORK(*)
      DOUBLE PRECISION  AINV(LDAINV,*), AINVB(LDAINB,*), C(LDC,*),
     $                  DWORK(*), E(*), QINV(LDQINV,*), RINV(LDRINV,*),
     $                  RINVY(*), SINV(LDSINV,*), X(*), Z(*)
C     .. Local Scalars ..
      LOGICAL           LJOBX, LMULTR
      INTEGER           I, I12, I13, I23, I32, I33, II, IJ, ITAU, JWORK,
     $                  LDW, M1, MP1, N1, NM, NP, WRKOPT
      DOUBLE PRECISION  RCOND
C     .. External Functions ..
      LOGICAL           LSAME
      DOUBLE PRECISION  DDOT
      EXTERNAL          DDOT, LSAME
C     .. External Subroutines ..
      EXTERNAL          DAXPY, DCOPY, DLACPY, DTRMM, DTRMV, MB02OD,
     $                  MB04ID, MB04KD, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         INT, MAX, MIN
C     .. Executable Statements ..
C
      NP = N + P
      NM = N + M
      N1 = MAX( 1, N )
      M1 = MAX( 1, M )
      MP1 = M + 1
      INFO = 0
      LJOBX  = LSAME( JOBX, 'X' )
      LMULTR = LSAME( MULTRC, 'P' )
C
C     Test the input scalar arguments.
C
      IF( .NOT.LJOBX .AND. .NOT.LSAME( JOBX, 'N' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.LMULTR .AND. .NOT.LSAME( MULTRC, 'N' ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( M.LT.0 ) THEN
         INFO = -4
      ELSE IF( P.LT.0 ) THEN
         INFO = -5
      ELSE IF( LDSINV.LT.N1 ) THEN
         INFO = -7
      ELSE IF( LDAINV.LT.N1 ) THEN
         INFO = -9
      ELSE IF( LDAINB.LT.N1 ) THEN
         INFO = -11
      ELSE IF( LDRINV.LT.1 .OR. ( .NOT.LMULTR .AND. LDRINV.LT.P ) ) THEN
         INFO = -13
      ELSE IF( LDC.LT.MAX( 1, P ) ) THEN
         INFO = -15
      ELSE IF( LDQINV.LT.M1 ) THEN
         INFO = -17
      ELSE IF( ( LJOBX .AND. LDWORK.LT.MAX( 2, N*(NM + M) + 3*M,
     $                                      NP*(N + 1) + N +
     $                                      MAX( N - 1, MP1 ), 3*N ) )
     $                                                             .OR.
     $    ( .NOT.LJOBX .AND. LDWORK.LT.MAX( 1, N*(NM + M) + 3*M,
     $                                      NP*(N + 1) + N +
     $                                      MAX( N - 1, MP1 ) ) ) ) THEN
         INFO = -25
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'FB01TD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( MAX( N, P ).EQ.0 ) THEN
         IF ( LJOBX ) THEN
            DWORK(1) = TWO
            DWORK(2) = ONE
         ELSE
            DWORK(1) = ONE
         END IF
         RETURN
      END IF
C
C     Construction of the needed part of the pre-array in DWORK.
C     To save workspace, only the blocks (1,3), (3,1)-(3,3), (2,2), and
C     (2,3) will be constructed when needed as shown below.
C
C     Storing SINV x AINVB and SINV x AINV in the (1,1) and (1,2)
C     blocks of DWORK, respectively. The upper trapezoidal structure of
C     [ AINVB AINV ] is fully exploited. Specifically, if M <= N, the
C     following partition is used:
C
C       [ S1  S2 ] [ B1  A1 A3 ]
C       [ 0   S3 ] [ 0   A2 A4 ],
C
C     where B1, A3, and S1 are M-by-M matrices, A1 and S2 are
C     M-by-(N-M), A2 and S3 are (N-M)-by-(N-M), A4 is (N-M)-by-M, and
C     B1, S1, A2, and S3 are upper triangular. The right hand side
C     matrix above is stored in the workspace. If M > N, the partition
C     is [ SINV ] [ B1 B2  A ], where B1 is N-by-N, B2 is N-by-(M-N),
C     and B1 and SINV are upper triangular.
C     The variables called Ixy define the starting positions where the
C     (x,y) blocks of the pre-array are initially stored in DWORK.
C     Workspace: need N*(M+N).
C
C     (Note: Comments in the code beginning "Workspace:" describe the
C     minimal amount of real workspace needed at that point in the
C     code, as well as the preferred amount for good performance.
C     NB refers to the optimal block size for the immediately
C     following subroutine, as returned by ILAENV.)
C
      LDW = N1
      I32 = N*M + 1
C
      CALL DLACPY( 'Upper', N, M, AINVB, LDAINB, DWORK, LDW )
      CALL DLACPY( 'Full',  MIN( M, N ), N, AINV, LDAINV, DWORK(I32),
     $             LDW )
      IF ( N.GT.M )
     $   CALL DLACPY( 'Upper', N-M, N, AINV(MP1,1), LDAINV,
     $                DWORK(I32+M), LDW )
C
C                    [ B1  A1 ]
C     Compute SINV x [ 0   A2 ] or SINV x B1 as a product of upper
C     triangular matrices.
C     Workspace: need N*(M+N+1).
C
      II  = 1
      I13 = N*NM + 1
      WRKOPT = MAX( 1, N*NM + N )
C
      DO 10 I = 1, N
         CALL DCOPY( I, DWORK(II), 1, DWORK(I13), 1 )
         CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I, SINV,
     $               LDSINV, DWORK(I13), 1 )
         CALL DCOPY( I, DWORK(I13), 1, DWORK(II), 1 )
         II = II + N
   10 CONTINUE
C
C                    [ A3 ]
C     Compute SINV x [ A4 ] or SINV x [ B2 A ].
C
      CALL DTRMM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, M,
     $            ONE, SINV, LDSINV, DWORK(II), LDW )
C
C     Storing the process noise mean value in (1,3) block of DWORK.
C     Workspace: need N*(M+N) + M.
C
      CALL DCOPY( M, Z, 1, DWORK(I13), 1 )
      CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', M, QINV, LDQINV,
     $            DWORK(I13), 1 )
C
C     Computing SINV x X in X.
C
      CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', N, SINV, LDSINV,
     $            X, 1 )
C
C     Triangularization (2 steps).
C
C     Step 1: annihilate the matrix SINV x AINVB.
C     Workspace: need N*(N+2*M) + 3*M.
C
      I12   = I13  + M
      ITAU  = I12  + M*N
      JWORK = ITAU + M
C
      CALL MB04KD( 'Upper', M, N, N, QINV, LDQINV, DWORK, LDW,
     $             DWORK(I32), LDW, DWORK(I12), M1, DWORK(ITAU),
     $             DWORK(JWORK) )
      WRKOPT = MAX( WRKOPT, N*( NM + M ) + 3*M )
C
      IF ( N.EQ.0 ) THEN
         CALL DCOPY( P, RINVY, 1, E, 1 )
         IF ( LJOBX )
     $      DWORK(2) = ONE
         DWORK(1) = WRKOPT
         RETURN
      END IF
C
C     Apply the transformations to the last column of the pre-array.
C     (Only the updated (3,3) block is now needed.)
C
      IJ = 1
C
      DO 20 I = 1, M
         CALL DAXPY( MIN( I, N ), -DWORK(ITAU+I-1)*( DWORK(I13+I-1) +
     $               DDOT( MIN( I, N ), DWORK(IJ), 1, X, 1 ) ),
     $                                  DWORK(IJ), 1, X, 1 )
         IJ = IJ + N
   20 CONTINUE
C
C     Now, the workspace for SINV x AINVB, as well as for the updated
C     (1,2) block of the pre-array, are no longer needed.
C     Move the computed (3,2) and (3,3) blocks of the pre-array in the
C     (1,1) and (1,2) block positions of DWORK, to save space for the
C     following computations.
C     Then, adjust the implicitly defined leading dimension of DWORK,
C     to make space for storing the (2,2) and (2,3) blocks of the
C     pre-array.
C     Workspace: need (P+N)*(N+1).
C
      CALL DLACPY( 'Full', MIN( M, N ), N, DWORK(I32), LDW, DWORK, LDW )
      IF ( N.GT.M )
     $   CALL DLACPY( 'Upper', N-M, N, DWORK(I32+M), LDW, DWORK(MP1),
     $                LDW )
      LDW = MAX( 1, NP )
C
      DO 40 I = N, 1, -1
         DO 30 IJ = MIN( N, I+M ), 1, -1
            DWORK(NP*(I-1)+P+IJ) = DWORK(N*(I-1)+IJ)
   30    CONTINUE
   40 CONTINUE
C
C     Copy of RINV x C in the (1,1) block of DWORK.
C
      CALL DLACPY( 'Full', P, N, C, LDC, DWORK, LDW )
      IF ( .NOT.LMULTR )
     $   CALL DTRMM( 'Left', 'Upper', 'No transpose', 'Non-unit', P, N,
     $               ONE, RINV, LDRINV, DWORK, LDW )
C
C     Copy the inclusion measurement in the (1,2) block and the updated
C     X in the (2,2) block of DWORK.
C
      I23 = NP*N + 1
      I33 = I23  + P
      CALL DCOPY( P, RINVY, 1, DWORK(I23), 1 )
      CALL DCOPY( N, X, 1, DWORK(I33), 1 )
      WRKOPT = MAX( WRKOPT, NP*( N + 1 ) )
C
C     Step 2: QR factorization of the first block column of the matrix
C
C        [ RINV x C     RINV x Y ],
C        [ SINV x AINV  SINV x X ]
C
C     where the second block row was modified at Step 1.
C     Workspace: need   (P+N)*(N+1) + N + MAX(N-1,M+1);
C                prefer (P+N)*(N+1) + N + (M+1)*NB, where NB is the
C                       optimal block size for DGEQRF called in MB04ID.
C
      ITAU  = I23  + NP
      JWORK = ITAU + N
C
      CALL MB04ID( NP, N, MAX( N-MP1, 0 ), 1, DWORK, LDW, DWORK(I23),
     $             LDW, DWORK(ITAU), DWORK(JWORK), LDWORK-JWORK+1,
     $             INFO )
      WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 )
C
C     Output SINV, X, and E and set the optimal workspace dimension
C     (and the reciprocal of the condition number estimate).
C
      CALL DLACPY( 'Upper', N, N, DWORK, LDW, SINV, LDSINV )
      CALL DCOPY( N, DWORK(I23), 1, X, 1 )
      IF( P.GT.0 )
     $   CALL DCOPY( P, DWORK(I23+N), 1, E, 1 )
C
      IF ( LJOBX ) THEN
C
C        Compute X.
C        Workspace: need 3*N.
C
         CALL MB02OD( 'Left', 'Upper', 'No transpose', 'Non-unit',
     $                '1-norm', N, 1, ONE, SINV, LDSINV, X, N, RCOND,
     $                TOL, IWORK, DWORK, INFO )
         IF ( INFO.EQ.0 ) THEN
            WRKOPT = MAX( WRKOPT, 3*N )
            DWORK(2) = RCOND
         END IF
      END IF
C
      DWORK(1) = WRKOPT
C
      RETURN
C *** Last line of FB01TD***
      END


      SUBROUTINE AB05SD( FBTYPE, JOBD, N, M, P, ALPHA, A, LDA, B, LDB,
     $                   C, LDC, D, LDD, F, LDF, RCOND, IWORK, DWORK,
     $                   LDWORK, INFO)
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To construct for a given state space system (A,B,C,D) the closed-
C     loop system (Ac,Bc,Cc,Dc) corresponding to the output feedback
C     control law
C
C          u = alpha*F*y + v.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     FBTYPE  CHARACTER*1
C             Specifies the type of the feedback law as follows:
C             = 'I':  Unitary output feedback (F = I);
C             = 'O':  General output feedback.
C
C     JOBD    CHARACTER*1
C             Specifies whether or not a non-zero matrix D appears in
C             the given state space model:
C             = 'D':  D is present;
C             = 'Z':  D is assumed a zero matrix.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The number of state variables, i.e. the order of the
C             matrix A, the number of rows of B and the number of
C             columns of C.  N >= 0.
C
C     M       (input) INTEGER
C             The number of input variables, i.e. the number of columns
C             of matrices B and D, and the number of rows of F.  M >= 0.
C
C     P       (input) INTEGER
C             The number of output variables, i.e. the number of rows of
C             matrices C and D, and the number of columns of F.  P >= 0
C             and P = M if FBTYPE = 'I'.
C
C     ALPHA   (input) DOUBLE PRECISION
C             The coefficient alpha in the output feedback law.
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 system state transition matrix A.
C             On exit, the leading N-by-N part of this array contains
C             the state matrix Ac of the closed-loop system.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,N).
C
C     B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
C             On entry, the leading N-by-M part of this array must
C             contain the system input matrix B.
C             On exit, the leading N-by-M part of this array contains
C             the input matrix Bc of the closed-loop system.
C
C     LDB     INTEGER
C             The leading dimension of array B.  LDB >= MAX(1,N).
C
C     C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
C             On entry, the leading P-by-N part of this array must
C             contain the system output matrix C.
C             On exit, the leading P-by-N part of this array contains
C             the output matrix Cc of the closed-loop system.
C
C     LDC     INTEGER
C             The leading dimension of array C.
C             LDC >= MAX(1,P) if N > 0.
C             LDC >= 1 if N = 0.
C
C     D       (input/output) DOUBLE PRECISION array, dimension (LDD,M)
C             On entry, the leading P-by-M part of this array must
C             contain the system direct input/output transmission
C             matrix D.
C             On exit, if JOBD = 'D', the leading P-by-M part of this
C             array contains the direct input/output transmission
C             matrix Dc of the closed-loop system.
C             The array D is not referenced if JOBD = 'Z'.
C
C     LDD     INTEGER
C             The leading dimension of array D.
C             LDD >= MAX(1,P) if JOBD = 'D'.
C             LDD >= 1 if JOBD = 'Z'.
C
C     F       (input) DOUBLE PRECISION array, dimension (LDF,P)
C             If FBTYPE = 'O', the leading M-by-P part of this array
C             must contain the output feedback matrix F.
C             If FBTYPE = 'I', then the feedback matrix is assumed to be
C             an M x M order identity matrix.
C             The array F is not referenced if FBTYPE = 'I' or
C             ALPHA = 0.
C
C     LDF     INTEGER
C             The leading dimension of array F.
C             LDF >= MAX(1,M) if FBTYPE = 'O' and ALPHA <> 0.
C             LDF >= 1 if FBTYPE = 'I' or ALPHA = 0.
C
C     RCOND   (output) DOUBLE PRECISION
C             The reciprocal condition number of the matrix
C             I - alpha*D*F.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (LIWORK)
C             LIWORK >= MAX(1,2*P) if JOBD = 'D'.
C             LIWORK >= 1 if JOBD = 'Z'.
C             IWORK is not referenced if JOBD = 'Z'.
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= wspace, where
C                       wspace = MAX( 1, M, P*P + 4*P ) if JOBD = 'D',
C                       wspace = MAX( 1, M ) if JOBD = 'Z'.
C             For best performance, LDWORK >= MAX( wspace, N*M, N*P ).
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = 1:  if the matrix I - alpha*D*F is numerically singular.
C
C     METHOD
C
C     The matrices of the closed-loop system have the expressions:
C
C     Ac = A + alpha*B*F*E*C,  Bc = B + alpha*B*F*E*D,
C     Cc = E*C,                Dc = E*D,
C
C     where E = (I - alpha*D*F)**-1.
C
C     NUMERICAL ASPECTS
C
C     The accuracy of computations basically depends on the conditioning
C     of the matrix I - alpha*D*F.  If RCOND is very small, it is likely
C     that the computed results are inaccurate.
C
C     CONTRIBUTORS
C
C     A. Varga, German Aerospace Research Establishment,
C     Oberpfaffenhofen, Germany, and V. Sima, Katholieke Univ. Leuven,
C     Belgium, Nov. 1996.
C
C     REVISIONS
C
C     January 14, 1997.
C     V. Sima, Research Institute for Informatics, Bucharest, July 2003.
C
C     KEYWORDS
C
C     Multivariable system, state-space model, state-space
C     representation.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         FBTYPE, JOBD
      INTEGER           INFO, LDA, LDB, LDC, LDD, LDF, LDWORK, M, N, P
      DOUBLE PRECISION  ALPHA, RCOND
C     .. Array Arguments ..
      INTEGER           IWORK(*)
      DOUBLE PRECISION  A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*),
     $                  DWORK(*), F(LDF,*)
C     .. Local Scalars ..
      LOGICAL           LJOBD, OUTPF, UNITF
      INTEGER           I, IW, LDWN, LDWP
      DOUBLE PRECISION  ENORM
C     .. Local Arrays ..
      DOUBLE PRECISION  DUMMY(1)
C     .. External functions ..
      LOGICAL           LSAME
      DOUBLE PRECISION  DLAMCH, DLANGE
      EXTERNAL          DLAMCH, DLANGE, LSAME
C     .. External subroutines ..
      EXTERNAL          DAXPY, DCOPY, DGECON, DGEMM, DGEMV, DGETRF,
     $                  DGETRS, DLACPY, DLASCL, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         MAX, MIN
C
C     .. Executable Statements ..
C
C     Check the input scalar arguments.
C
      UNITF = LSAME( FBTYPE, 'I' )
      OUTPF = LSAME( FBTYPE, 'O' )
      LJOBD = LSAME( JOBD, 'D' )
      LDWN = MAX( 1, N )
      LDWP = MAX( 1, P )
C
      INFO = 0
C
      IF( .NOT.UNITF .AND. .NOT.OUTPF ) THEN
         INFO = -1
      ELSE IF( .NOT.LJOBD .AND. .NOT.LSAME( JOBD, 'Z' )  ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( M.LT.0 ) THEN
         INFO = -4
      ELSE IF( P.LT.0 .OR. UNITF.AND.P.NE.M ) THEN
         INFO = -5
      ELSE IF( LDA.LT.LDWN ) THEN
         INFO = -7
      ELSE IF( LDB.LT.LDWN ) THEN
         INFO = -9
      ELSE IF( ( N.GT.0 .AND. LDC.LT.LDWP ) .OR.
     $         ( N.EQ.0 .AND. LDC.LT.1 ) ) THEN
         INFO = -11
      ELSE IF( ( LJOBD .AND. LDD.LT.LDWP ) .OR.
     $    ( .NOT.LJOBD .AND. LDD.LT.1 ) ) THEN
         INFO = -13
      ELSE IF( ( OUTPF .AND. ALPHA.NE.ZERO .AND. LDF.LT.MAX( 1, M ) )
     $  .OR. ( ( UNITF .OR.  ALPHA.EQ.ZERO ) .AND. LDF.LT.1 ) ) THEN
         INFO = -16
      ELSE IF( ( LJOBD .AND. LDWORK.LT.MAX( 1, M, P*P + 4*P ) ) .OR.
     $    ( .NOT.LJOBD .AND. LDWORK.LT.MAX( 1, M ) ) ) THEN
         INFO = -20
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'AB05SD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      RCOND = ONE
      IF ( MAX( N, MIN( M, P ) ).EQ.0 .OR. ALPHA.EQ.ZERO )
     $   RETURN
C
      IF (LJOBD) THEN
         IW = P*P + 1
C
C        Compute I - alpha*D*F.
C
         IF( UNITF) THEN
            CALL DLACPY( 'F', P, P, D, LDD, DWORK, LDWP )
            IF ( ALPHA.NE.-ONE )
     $         CALL DLASCL( 'G', 0, 0, ONE, -ALPHA, P, P, DWORK, LDWP,
     $                      INFO )
         ELSE
            CALL DGEMM( 'N', 'N', P, P, M, -ALPHA, D, LDD, F, LDF, ZERO,
     $                  DWORK, LDWP )
         END IF
C
         DUMMY(1) = ONE
         CALL DAXPY( P, ONE, DUMMY, 0, DWORK, P+1 )
C
C        Compute Cc = E*C, Dc = E*D, where E = (I - alpha*D*F)**-1.
C
         ENORM = DLANGE( '1', P, P, DWORK, LDWP, DWORK(IW) )
         CALL DGETRF( P, P, DWORK, LDWP, IWORK, INFO )
         IF( INFO.GT.0 ) THEN
C
C           Error return.
C
            RCOND = ZERO
            INFO = 1
            RETURN
         END IF
         CALL DGECON( '1', P, DWORK, LDWP, ENORM, RCOND, DWORK(IW),
     $                IWORK(P+1), INFO )
         IF( RCOND.LE.DLAMCH('E') ) THEN
C
C           Error return.
C
            INFO = 1
            RETURN
         END IF
C
         IF( N.GT.0 )
     $      CALL DGETRS( 'N', P, N, DWORK, LDWP, IWORK, C, LDC, INFO )
         CALL DGETRS( 'N', P, M, DWORK, LDWP, IWORK, D, LDD, INFO )
      END IF
C
      IF ( N.EQ.0 )
     $   RETURN
C
C     Compute Ac = A + alpha*B*F*Cc and Bc = B + alpha*B*F*Dc.
C
      IF( UNITF ) THEN
         CALL DGEMM( 'N', 'N', N, N, M, ALPHA, B, LDB, C, LDC, ONE, A,
     $               LDA )
         IF( LJOBD ) THEN
C
            IF( LDWORK.LT.N*M ) THEN
C
C              Not enough working space for using DGEMM.
C
               DO 10 I = 1, N
                  CALL DCOPY( P, B(I,1), LDB, DWORK, 1 )
                  CALL DGEMV( 'T', P, P, ALPHA, D, LDD, DWORK, 1, ONE,
     $                        B(I,1), LDB )
   10          CONTINUE
C
            ELSE
               CALL DLACPY( 'F', N, M, B, LDB, DWORK, LDWN )
               CALL DGEMM( 'N', 'N', N, P, M, ALPHA, DWORK, LDWN, D,
     $                     LDD, ONE, B, LDB )
            END IF
         END IF
      ELSE
C
         IF( LDWORK.LT.N*P ) THEN
C
C           Not enough working space for using DGEMM.
C
            DO 20 I = 1, N
               CALL DGEMV( 'N', M, P, ALPHA, F, LDF, C(1,I), 1, ZERO,
     $                     DWORK, 1 )
               CALL DGEMV( 'N', N, M, ONE, B, LDB, DWORK, 1, ONE,
     $                     A(1,I), 1 )
   20       CONTINUE
C
            IF( LJOBD ) THEN
C
               DO 30 I = 1, N
                  CALL DGEMV( 'T', M, P, ALPHA, F, LDF, B(I,1), LDB,
     $                        ZERO, DWORK, 1 )
                  CALL DGEMV( 'T', P, M, ONE, D, LDD, DWORK, 1, ONE,
     $                        B(I,1), LDB )
   30          CONTINUE
C
            END IF
         ELSE
C
            CALL DGEMM( 'N', 'N', N, P, M, ALPHA, B, LDB, F, LDF,
     $                  ZERO, DWORK, LDWN )
            CALL DGEMM( 'N', 'N', N, N, P, ONE, DWORK, LDWN, C, LDC,
     $                  ONE, A, LDA )
            IF( LJOBD )
     $         CALL DGEMM( 'N', 'N', N, M, P, ONE, DWORK, LDWN, D, LDD,
     $                     ONE, B, LDB )
         END IF
      END IF
C
      RETURN
C *** Last line of AB05SD ***
      END


! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
! See https://llvm.org/LICENSE.txt for license information.
! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception

! typed forall indexes

integer, parameter :: N = 6

integer :: i = -33
integer :: a(N) = 0
integer :: s = 0

forall (integer*1 :: i=N:1:-1) a(i) =  1; s = s + sum(a)/N  !  1
forall (integer*2 :: i=N:1:-1) a(i) =  2; s = s + sum(a)/N  !  3
forall (             i=N:1:-1) a(i) =  3; s = s + sum(a)/N  !  6
forall (integer*8 :: i=N:1:-1) a(i) =  4; s = s + sum(a)/N  ! 10
forall (integer*1 :: i=N:1:-1) a(i) =  5; s = s + sum(a)/N  ! 15
forall (integer*2 :: i=N:1:-1) a(i) =  6; s = s + sum(a)/N  ! 21
forall (             i=N:1:-1) a(i) =  7; s = s + sum(a)/N  ! 28
forall (             i=N:1:-1) a(i) =  8; s = s + sum(a)/N  ! 36
forall (integer*4 :: i=N:1:-1) a(i) =  9; s = s + sum(a)/N  ! 45
forall (integer*8 :: i=N:1:-1) a(i) = 10; s = s + sum(a)/N  ! 55

if (s .ne. 55 .or.  i .ne. -33) print*, 'FAIL'
if (s .eq. 55 .and. i .eq. -33) print*, 'PASS'
end