      SUBROUTINE SBSOL (MODE,G,LDG,NB,IR,JTPREV,X,N,RNORM, IERR3)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C>> 1994-11-11 SBSOL  Krogh  Declared all vars.
C>> 1994-10-20 SBSOL  Krogh  Changes to use M77CON
C>> 1987-11-24 SBSOL  Lawson Initial code.
c--S replaces "?": ?BSOL
c     Solution of banded least squares problem following use of _BACC to
c     accumulate the data.
c     ------------------------------------------------------------------
c                            Subroutine arguments
c
C     MODE  [in]  Flag selecting operation to be done.
c          = 1     SOLVE R*X=Y   WHERE R AND Y ARE IN THE G( ) ARRAY
C                  AND X WILL BE STORED IN THE X( ) ARRAY.
C            2     SOLVE (R**T)*X=Y   WHERE R IS IN G( ),
C                  Y IS INITIALLY IN X( ), AND X REPLACES Y IN X( ),
C            3     SOLVE R*X=Y   WHERE R IS IN G( ).
C                  Y IS INITIALLY IN X( ), AND X REPLACES Y IN X( ).
C
c     G(,)  [in]  Array in which the transformed problem data has
c           been left by _BACC.
c     LDG   [in]  Leading dimensioning parameter for G(,).
c     NB    [in]  Bandwidth of data matrix.
c     IR    [in]  Must have value set by previous call to _BACC.
c     JTPREV    [in]  Must have value set by previous call to _BACC.
c     X()   [inout]  Array of length at least N.
c           On entry with MODE = 2 or 3 contains the y vector.
c           In all (non-error) cases contains the solution vector on
c           return.
c     N     [in]  Specifies the dimension of the desired solution
c           vector.  Can be set smaller than the max value the data
c           would support.
c     RNORM  [out]  Set to the euclidean norm of the residual vector
c           when MODE = 1.  Set to zero otherwise.
c     IERR3  [out]  =0 means no errors detected.
c                  =1 means a diagonal element is zero.
c     ------------------------------------------------------------------
C     C.L.LAWSON AND R.J.HANSON, JET PROPULSION LABORATORY, 1973 JUN 12
C     Reference:   'SOLVING LEAST SQUARES PROBLEMS', PRENTICE-HALL, 1974
c     Comments in this code refer to Algorithm Step numbers on
c     pp 213-217 of the book.
c     ------------------------------------------------------------------
c     1984 July 11, C. L. Lawson, JPL.  Adapted code from book
c     to Fortran 77 for JPL MATH 77 library.
c     Prefixing subprogram names with S or D for s.p. or d.p. versions.
c     Using generic names for any intrinsic functions.
c     July 1987.  Using _HTCC in place of _H12.
c     ------------------------------------------------------------------
c     Subprograms called: IERM1, IERV1
c     ------------------------------------------------------------------
      integer MODE, LDG, NB, JTPREV, IR, N, IERR3
      integer J, NP1, IRM1, II, I, L, IE, JG, IX, I1, I2
      real             G(LDG,NB+1),X(N), ZERO, RNORM, RSQ, S
      parameter( ZERO = 0.0E0)
c     ------------------------------------------------------------------
C
      IERR3 = 0
      RNORM=ZERO
      if( MODE .eq. 1) then
C                                   ********************* MODE = 1
C                                   ALG. STEP 26
         DO 20 J=1,N
   20       X(J)=G(J,NB+1)
         RSQ=ZERO
         NP1=N+1
         IRM1=IR-1
         if (NP1 .le. IRM1) then
            DO 30 J=NP1,IRM1
   30            RSQ=RSQ+G(J,NB+1)**2
            RNORM=SQRT(RSQ)
         endif
      endif
c
      if( MODE .eq. 2) go to 90
C                                   ********************* MODE = 1 or 3
C                                   ALG. STEP 27
           DO 80 II=1,N
           I=N+1-II
C                                   ALG. STEP 28
           S=ZERO
           L=MAX(0,I-JTPREV)
C                                   ALG. STEP 29
           if (I .ne. N) then
C                                   ALG. STEP 30
              IE=MIN(N+1-I,NB)
              DO 60 J=2,IE
                 JG=J+L
                 IX=I-1+J
   60            S=S+G(I,JG)*X(IX)
           endif
C                                   ALG. STEP 31
           if (G(I,L+1) .eq. ZERO) go to 130
   80      X(I)=(X(I)-S)/G(I,L+1)
C                                   ALG. STEP 32
      return
C     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C                                   ********************* MODE = 2
   90      DO 120 J=1,N
              S=ZERO
              if (J .ne. 1) then
                 I1=MAX(1,J-NB+1)
                 I2=J-1
                 DO 100 I=I1,I2
                    L=J-I+1+MAX(0,I-JTPREV)
  100               S=S+X(I)*G(I,L)
              endif
              L=MAX(0,J-JTPREV)
              if (G(J,L+1) .eq. ZERO) then
                 I = J
                 go to 130
              endif
  120         X(J)=(X(J)-S)/G(J,L+1)
      return
C     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  130 continue
      IERR3 = I
      call IERM1('SBSOL', IERR3, 0,'Singular matrix',
     * 'MODE', MODE, ',')
      call IERV1('Index of zero diag elt', I, '.')
      return
      end


*     AB08NW EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      DOUBLE PRECISION ZERO
      PARAMETER        ( ZERO = 0.0D0 )
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, PMAX
      PARAMETER        ( NMAX = 20, MMAX = 20, PMAX = 20 )
      INTEGER          MPMAX
      PARAMETER        ( MPMAX = MAX( MMAX, PMAX ) )
      INTEGER          LDA, LDB, LDC, LDD, LDE, LDQ, LDZ
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDC = PMAX,
     $                   LDD = PMAX, LDE = NMAX, LDQ = 1, LDZ = 1 )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = MAX( MAX( MIN( PMAX, MMAX ) + MMAX +
     $                                      MAX( 2*MMAX, NMAX ) - 1,
     $                                      MIN( PMAX, NMAX ) +
     $                                      MAX( NMAX + MPMAX,
     $                                           3*PMAX - 1 ) ) +
     $                                 ( NMAX + MPMAX )**2, 8*NMAX ) )
*     .. Local Scalars ..
      DOUBLE PRECISION TOL
      INTEGER          DINFZ, I, INFO, J, M, N, NFZ, NINFE, NIZ, NKROL,
     $                 NKROR, NRANK, P
      CHARACTER*1      EQUIL
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), ALFI(NMAX), ALFR(NMAX),
     $                 AS(LDA,NMAX), B(LDB,MMAX), BS(LDB,MMAX),
     $                 BETA(NMAX), C(LDC,NMAX), CS(LDC,NMAX),
     $                 D(LDD,MMAX), DWORK(LDWORK), E(LDE,NMAX),
     $                 Q(LDQ,1), Z(LDZ,1)
      INTEGER          INFE(NMAX+1), INFZ(NMAX+1), IWORK(MPMAX),
     $                 KRONL(NMAX+1), KRONR(NMAX+1)
*     .. External Subroutines ..
      EXTERNAL         AB08NW, DLACPY, DGEGV
*     .. Intrinsic Functions ..
      INTRINSIC        MAX, MIN
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, P, TOL, EQUIL
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99972 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99971 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N )
            IF ( P.LT.0 .OR. P.GT.PMAX ) THEN
               WRITE ( NOUT, FMT = 99970 ) P
            ELSE
               READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P )
               READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P )
*              Save the matrices A, B, and C.
               CALL DLACPY( 'Full', N, N, A, LDA, AS, LDA )
               CALL DLACPY( 'Full', N, M, B, LDB, BS, LDB )
               CALL DLACPY( 'Full', P, N, C, LDC, CS, LDC )
*              Check the observability and compute the ordered set of
*              the observability indices (call the routine with M = 0).
               CALL AB08NW( EQUIL, N, 0, P, A, LDA, B, LDB, C, LDC, D,
     $                      LDD, NFZ, NRANK, NIZ, DINFZ, NKROR, NINFE,
     $                      NKROL, INFZ, KRONR, INFE, KRONL, E, LDE,
     $                      TOL, IWORK, DWORK, LDWORK, INFO )
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99994 ) ( KRONL(I), I = 1,P )
                  IF ( NFZ.EQ.0 ) THEN
                     WRITE ( NOUT, FMT = 99993 )
                  ELSE
                     WRITE ( NOUT, FMT = 99992 ) N - NFZ
                     WRITE ( NOUT, FMT = 99991 )
                     WRITE ( NOUT, FMT = 99990 )
                     DO 20 I = 1, NFZ
                        WRITE ( NOUT, FMT = 99989 )
     $                        ( A(I,J), J = 1,NFZ )
   20                CONTINUE
                  END IF
               END IF
*              Restore the matrices A and C.
               CALL DLACPY( 'Full', N, N, AS, LDA, A, LDA )
               CALL DLACPY( 'Full', P, N, CS, LDC, C, LDC )
*              Check the controllability and compute the ordered set of
*              the controllability indices (call the routine with P = 0)
               CALL AB08NW( EQUIL, N, M, 0, A, LDA, B, LDB, C, LDC, D,
     $                      LDD, NFZ, NRANK, NIZ, DINFZ, NKROR, NINFE,
     $                      NKROL, INFZ, KRONR, INFE, KRONL, E, LDE,
     $                      TOL, IWORK, DWORK, LDWORK, INFO )
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99988 ) ( KRONR(I), I = 1,M )
                  IF ( NFZ.EQ.0 ) THEN
                     WRITE ( NOUT, FMT = 99987 )
                  ELSE
                     WRITE ( NOUT, FMT = 99986 ) N - NFZ
                     WRITE ( NOUT, FMT = 99985 )
                     WRITE ( NOUT, FMT = 99990 )
                     DO 40 I = 1, NFZ
                        WRITE ( NOUT, FMT = 99989 )
     $                        ( A(I,J), J = 1,NFZ )
   40                CONTINUE
                  END IF
               END IF
*              Restore the matrices A and B.
               CALL DLACPY( 'Full', N, N, AS, LDA, A, LDA )
               CALL DLACPY( 'Full', N, M, BS, LDB, B, LDB )
*              Compute the structural invariants of the given system.
               CALL AB08NW( EQUIL, N, M, P, A, LDA, B, LDB, C, LDC, D,
     $                      LDD, NFZ, NRANK, NIZ, DINFZ, NKROR, NINFE,
     $                      NKROL, INFZ, KRONR, INFE, KRONL, E, LDE,
     $                      TOL, IWORK, DWORK, LDWORK, INFO )
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99984 ) NFZ
                  IF ( NFZ.GT.0 ) THEN
*                    Compute the invariant zeros of the given system.
*                    Workspace: need 8*NFZ.
                     WRITE ( NOUT, FMT = 99983 )
                     CALL DGEGV( 'No vectors', 'No vectors', NFZ, A,
     $                           LDA, E, LDE, ALFR, ALFI, BETA, Q,
     $                           LDQ, Z, LDZ, DWORK, LDWORK, INFO )
*
                     IF ( INFO.NE.0 ) THEN
                        WRITE ( NOUT, FMT = 99997 ) INFO
                     ELSE
                        WRITE ( NOUT, FMT = 99981 )
                        DO 60 I = 1, NFZ
                           IF ( ALFI(I).EQ.ZERO ) THEN
                              WRITE ( NOUT, FMT = 99980 )
     $                                ALFR(I)/BETA(I)
                           ELSE
                              WRITE ( NOUT, FMT = 99979 )
     $                                ALFR(I)/BETA(I),
     $                                ALFI(I)/BETA(I)
                           END IF
   60                   CONTINUE
                        WRITE ( NOUT, FMT = 99982 )
                     END IF
                  END IF
                  WRITE ( NOUT, FMT = 99978 ) NIZ
                  IF ( NIZ.GT.0 ) THEN
                     DO 100 I = 1, DINFZ
                        WRITE ( NOUT, FMT = 99977 ) INFZ(I), I
  100                CONTINUE
                  END IF
                  WRITE ( NOUT, FMT = 99976 ) NKROR
                  IF ( NKROR.GT.0 ) WRITE ( NOUT, FMT = 99975 )
     $                                      ( KRONR(I), I = 1,NKROR )
                  WRITE ( NOUT, FMT = 99974 ) NKROL
                  IF ( NKROL.GT.0 ) WRITE ( NOUT, FMT = 99973 )
     $                                      ( KRONL(I), I = 1,NKROL )
                  IF ( NINFE.GT.0 ) WRITE ( NOUT, FMT = 99969 )
     $                                      ( INFE(I), I = 1,NINFE )
               END IF
            END IF
         END IF
      END IF
*
      STOP
*
99999 FORMAT (' AB08NW EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from AB08NW = ',I2)
99997 FORMAT (' INFO on exit from DGEGV = ',I2)
99994 FORMAT (' The left Kronecker indices of (A,C) are ',/(20(I3,2X)))
99993 FORMAT (/' The system (A,C) is completely observable ')
99992 FORMAT (/' The dimension of the observable subspace = ',I3)
99991 FORMAT (/' The output decoupling zeros are the eigenvalues of th',
     $       'e matrix AF. ')
99990 FORMAT (/' The matrix AF is ')
99989 FORMAT (20(1X,F8.4))
99988 FORMAT (//' The right Kronecker indices of (A,B) are ',/(20(I3,2X)
     $       ))
99987 FORMAT (/' The system (A,B) is completely controllable ')
99986 FORMAT (/' The dimension of the controllable subspace = ',I3)
99985 FORMAT (/' The input decoupling zeros are the eigenvalues of the',
     $       ' matrix AF. ')
99984 FORMAT (//' The number of finite invariant zeros = ',I3)
99983 FORMAT (/' The finite invariant zeros are ')
99982 FORMAT (/' which correspond to the generalized eigenvalues of (l',
     $       'ambda*EF - AF).')
99981 FORMAT (/' real  part     imag  part ')
99980 FORMAT (1X,F9.4)
99979 FORMAT (1X,F9.4,6X,F9.4)
99978 FORMAT (//' The number of infinite zeros = ',I3)
99977 FORMAT ( I4,' infinite zero(s) of order ',I3)
99976 FORMAT (/' The number of right Kronecker indices = ',I3)
99975 FORMAT (/' Right Kronecker (column) indices of (A,B,C,D) are ',
     $       /(20(I3,2X)))
99974 FORMAT (/' The number of left Kronecker indices = ',I3)
99973 FORMAT (/' The left Kronecker (row) indices of (A,B,C,D) are ',
     $       /(20(I3,2X)))
99972 FORMAT (/' N is out of range.',/' N = ',I5)
99971 FORMAT (/' M is out of range.',/' M = ',I5)
99970 FORMAT (/' P is out of range.',/' P = ',I5)
99969 FORMAT (/' Multiplicities of infinite eigenvalues',/(20(I3,2X)))
      END


cb::inverse
c
      program inverse
c
c********1*********2*********3*********4*********5*********6*********7**
c
c name:      inverse
c version:   201211.29
c author:    stephen j. frakes
c last mod:  Charles Karney
c purpose:   to compute a geodetic inverse
c            and then display output information
c
c input parameters:
c -----------------
c
c output parameters:
c ------------------
c
c local variables and constants:
c ------------------------------
c answer           user prompt response
c b                semiminor axis polar (in meters)
c baz              azimuth back (in radians)
c buff             input char buffer array
c dd,dm,ds         temporary values for degrees, minutes, seconds
c dlon             temporary value for difference in longitude (radians)
c dmt,d_mt         char constants for meter units
c edist            ellipsoid distance (in meters)
c elips            ellipsoid choice
c esq              eccentricity squared for reference ellipsoid
c faz              azimuth forward (in radians)
c filout           output file name
c finv             reciprocal flattening
c hem              hemisphere flag for lat & lon entry
c ierror           error condition flag with d,m,s conversion
c lgh              length of buff() array
c option           user prompt response
c r1,r2            temporary variables
c ss               temporary variable
c tol              tolerance for conversion of seconds
c
c name1            name of station one
c ld1,lm1,sl1      latitude  sta one - degrees,minutes,seconds
c ald1,alm1,sl1    latitude  sta one - degrees,minutes,seconds
c lat1sn           latitude  sta one - sign (+/- 1)
c d_ns1            latitude  sta one - char ('N','S')
c lod1,lom1,slo1   longitude sta one - degrees,minutes,seconds
c alod1,alom1,slo1 longitude sta one - degrees,minutes,seconds
c lon1sn           longitude sta one - sign (+/- 1)
c d_ew1            longitude sta one - char ('E','W')
c iaz1,maz1,saz1   forward azimuth   - degrees,minutes,seconds
c isign1           forward azimuth   - flag  (+/- 1)
c glat1,glon1      station one       - (lat & lon in radians )
c p1,e1            standpoint one    - (lat & lon in radians )
c
c name2            name of station two
c ld2,lm2,sl2      latitude  sta two - degrees,minutes,seconds
c ald2,alm2,sl2    latitude  sta two - degrees,minutes,seconds
c lat2sn           latitude  sta two - sign (+/- 1)
c d_ns2            latitude  sta two - char ('N','S')
c lod2,lom2,slo2   longitude sta two - degrees,minutes,seconds
c alod2,alom2,slo2 longitude sta one - degrees,minutes,seconds
c lon2sn           longitude sta two - sign (+/- 1)
c d_ew2            longitude sta two - char ('E','W')
c iaz2,maz2,saz2   back azimuth      - degrees,minutes,seconds
c isign2           back azimuth      - flag  (+/- 1)
c glat2,glon2      station two       - (lat & lon in radians )
c p2,e2            forepoint two     - (lat & lon in radians )
c
c global variables and constants:
c -------------------------------
c a                semimajor axis equatorial (in meters)
c f                flattening
c pi               constant 3.14159....
c rad              constant 180.0/pi
c
c    this module called by:  n/a
c
c    this module calls:      elipss, getdeg, inver1, todmsp
c    gethem, trim,   bufdms, gvalr8, gvali4, fixdms, gpnhri ***********
c    gethem, trim,   bufdms, gvalr8, gvali4, fixdms, invers <----------
c    datan,  write,  read,   dabs,   open,   stop
c
c    include files used:     n/a
c
c    common blocks used:     const, elipsoid
c
c    references:             see comments within subroutines
c
c    comments:
c
c********1*********2*********3*********4*********5*********6*********7**
c::modification history
c::1990mm.dd, sjf, creation of program
c::199412.15, bmt, creation of program on viper
c::200203.08, crs, modified by c.schwarz to correct spelling of Clarke
c::200207.15, rws, modified i/o & standardized program documentation
c::                added subs trim, bufdms, gethem, gvali4, gvalr8
c::200207.23, rws, replaced sub inver1 with gpnarc, gpnloa, gpnhri
c::200208.15, rws, fixed an error in bufdms
c::              - renamed ellips to elipss "common error" with dirct2
c::              - added FAZ & BAZ to printed output
c::200208.19, rws, added more error flags for web interface code
c::              - added logical nowebb
c::200208.xx, sjf, program version number 2.0
c::201105.xx, dgm, program version number 3.0
c::              - replaced sub gpnarc, gpnloa, gpnhri with invers
c::              - tested for valid antipodal solutions (+/- 0.1 mm)
c::              - tested for polar solutions (+/- 0.1 mm)
c::              - needs improvement for long-line/antipodal boundary
c::201211.29, cffk, program version numer 3.1
c::              - drop in replacement routines from
c::                "Algorithms for Geodesics"
c********1*********2*********3*********4*********5*********6*********7**
ce::inverse
c
      implicit double precision (a-h, o-z)
      implicit integer (i-n)
c
      logical  nowebb
c
      character*1  answer,option,dmt,buff(50),hem
      character*6  d_ns1, d_ew1, d_ns2, d_ew2, d_mt
      character*30 filout,name1,name2,elips
c
      integer*4    ierror
      integer*4    lgh
c
      common/const/pi,rad
      common/elipsoid/a,f
c
c     ms_unix      0 = web version
c                  1 = ms_dos or unix version
c
      parameter   ( ms_unix = 0 )
c
      pi   = 4.d0*datan(1.d0)
      rad  = 180.d0/pi
      dmt  = 'm'
      d_mt = 'Meters'
c
      if( ms_unix.eq.1 )then
        nowebb = .true.
      else
        nowebb = .false.
      endif
c
    1 do 2 i=1,25
        write(*,*) '  '
    2 continue
c
    5 write(*,*) '  Program Inverse  -  Version 3.1 '
      write(*,*) '  '
      write(*,*) '  Ellipsoid options : '
      write(*,*) '  '
      write(*,*) '  1) GRS80 / WGS84  (NAD83) '
      write(*,*) '  2) Clarke 1866    (NAD27) '
      write(*,*) '  3) Any other ellipsoid '
      write(*,*) '  '
      write(*,*) '  Enter choice : '
      read(*,10) option
   10 format(a1)
c
      if(option.eq.'1') then
        a=6378137.d0
        f=1.d0/298.257222100882711243162836600094d0
        elips='GRS80 / WGS84  (NAD83)'
      elseif(option.eq.'2') then
        a=6378206.4d0
        f=1.d0/294.9786982138d0
        elips='Clarke 1866    (NAD27)'
      elseif(option.eq.'3') then
        call elipss (elips)
      else
        write(*,*) '  Enter 1, 2, or 3 !   Try again --'
        goto 5
      endif
c
      esq = f*(2.0d0-f)
c
      write(*,*) '  '
      write(*,*) '  '
      write(*,*) '  '
      write(*,*) '  '
c
   15 write(*,*) '  Enter First Station '
      write(*,16)
   16 format(18x,'(Separate D,M,S by blanks or commas)')
      write(*,*) 'hDD MM SS.sssss  Latitude :        (h default = N )'
   11 format(50a1)
c
   22 hem='N'
      read(*,11) buff
      call trim (buff,lgh,hem)
      call bufdms (buff,lgh,hem,dd,dm,ds,ierror)
c
      if( ierror.eq.0 )then
        irlat1 = 0
      else
        irlat1 = 1
        write(*,*) ' Invalid Latitude ... Please re-enter it '
        write(*,*) '  '
        if( nowebb )then
          goto 22
        endif
      endif
c
      ald1 = dd
      alm1 = dm
      sl1  = ds
c
      if( hem.eq.'N' ) then
        lat1sn = +1
      else
        lat1sn = -1
      endif
c
      write(*,*) 'hDDD MM SS.sssss Longitude :       (h default = W )'
c
   23 hem='W'
      read(*,11) buff
      call trim (buff,lgh,hem)
      call bufdms (buff,lgh,hem,dd,dm,ds,ierror)
c
      if( ierror.eq.0 )then
        irlon1 = 0
      else
        irlon1 = 1
        write(*,*) ' Invalid Longitude ... Please re-enter it '
        write(*,*) '  '
        if( nowebb )then
          goto 23
        endif
      endif
c
      alod1 = dd
      alom1 = dm
      slo1  = ds
c
      if( hem.eq.'E' ) then
        lon1sn = +1
      else
        lon1sn = -1
      endif
c
      call getdeg(ald1, alm1, sl1, lat1sn, glat1)
      call getdeg(alod1,alom1,slo1,lon1sn, glon1)
c
      write(*,*) '  '
      write(*,*) '  '
c
   20 write(*,*) '  Enter Second Station '
      write(*,16)
      write(*,*) 'hDD MM SS.sssss  Latitude :        (h default = N )'
c
   24 hem='N'
      read(*,11) buff
      call trim (buff,lgh,hem)
      call bufdms (buff,lgh,hem,dd,dm,ds,ierror)
c
      if( ierror.eq.0 )then
        irlat2 = 0
      else
        irlat2 = 1
        write(*,*) ' Invalid Latitude ... Please re-enter it '
        write(*,*) '  '
        if( nowebb )then
          goto 24
        endif
      endif
c
      ald2 = dd
      alm2 = dm
      sl2  = ds
c
      if( hem.eq.'N' ) then
        lat2sn = +1
      else
        lat2sn = -1
      endif
c
      write(*,*) 'hDDD MM SS.sssss Longitude :       (h default = W )'
c
   25 hem='W'
      read(*,11) buff
      call trim (buff,lgh,hem)
      call bufdms (buff,lgh,hem,dd,dm,ds,ierror)
c
      if( ierror.eq.0 )then
        irlon2 = 0
      else
        irlon2 = 1
        write(*,*) ' Invalid Longitude ... Please re-enter it '
        write(*,*) '  '
        if( nowebb )then
          goto 25
        endif
      endif
c
      alod2 = dd
      alom2 = dm
      slo2  = ds
c
      if( hem.eq.'E' )then
        lon2sn = +1
      else
        lon2sn = -1
      endif
c
      call getdeg(ald2, alm2, sl2, lat2sn, glat2)
      call getdeg(alod2,alom2,slo2,lon2sn, glon2)
c
      p1 = glat1
      e1 = glon1
      p2 = glat2
      e2 = glon2
c
      if( e1.lt.0.0d0 )then
        e1 = e1+2.0d0*pi
      endif
      if( e2.lt.0.0d0 )then
        e2 = e2+2.0d0*pi
      endif
c
c     compute the geodetic inverse
c
      call invers(a, f, p1, e1, p2, e2,
     +    edist, faz, baz, 0, dummy, dummy, dummy, dummy, dummy)
      if (baz .ge. 0) then
        baz = baz - 180
      else
        baz = baz + 180
      end if
c
c     set the tolerance (in seconds) for the azimuth conversion
c
      tol = 0.00005d0
c
      call todmsp(faz,iaz1,maz1,saz1,isign1)
      if(isign1.lt.0) then
        iaz1=359-iaz1
        maz1=59-maz1
        saz1=60.d0-saz1
      endif
      call fixdms ( iaz1, maz1, saz1, tol )
c
      call todmsp(baz,iaz2,maz2,saz2,isign2)
      if(isign2.lt.0) then
        iaz2=359-iaz2
        maz2=59-maz2
        saz2=60.d0-saz2
      endif
      call fixdms ( iaz2, maz2, saz2, tol )
c
      call todmsp(glat1, ld1,  lm1,  sl1,  lat1sn)
      call todmsp(glon1, lod1, lom1, slo1, lon1sn)
      call todmsp(glat2, ld2,  lm2,  sl2,  lat2sn)
      call todmsp(glon2, lod2, lom2, slo2, lon2sn)
c
      call hem_ns ( lat1sn, d_ns1 )
      call hem_ew ( lon1sn, d_ew1 )
      call hem_ns ( lat2sn, d_ns2 )
      call hem_ew ( lon2sn, d_ew2 )
c
      write(*,*) '  '
      write(*,*) '  '
      write(*,*) '  '
      write(*,*) '  '
      write(*,*) '  '
      write(*,49) elips
   49 format('  Ellipsoid : ',a30)
      finv=1.d0/f
      b=a*(1.d0-f)
      write(*,50) a,b,finv
   50 format('  Equatorial axis,    a   = ',f15.4,/,
     *       '  Polar axis,         b   = ',f15.4,/,
     *       '  Inverse flattening, 1/f = ',f16.11)
c
   18 format('    LAT = ',i3,1x,i2,1x,f8.5,1x,a6)
   19 format('    LON = ',i3,1x,i2,1x,f8.5,1x,a6)
c
      write(*,*) '  '
      write(*,*) '  First  Station : '
      write(*,*) '  ---------------- '
      write(*,18) ld1, lm1, sl1, d_ns1
      write(*,19) lod1,lom1,slo1,d_ew1
c
      write(*,*) '  '
      write(*,*) '  Second Station : '
      write(*,*) '  ---------------- '
      write(*,18) ld2, lm2, sl2, d_ns2
      write(*,19) lod2,lom2,slo2,d_ew2
c
   32 format('  Ellipsoidal distance     S = ',f14.4,1x,a1)
   34 format('  Forward azimuth        FAZ = ',i3,1x,i2,1x,f7.4,
     1       ' From North')
   35 format('  Back azimuth           BAZ = ',i3,1x,i2,1x,f7.4,
     1       ' From North')
c
      write(*,*) '  '
      write(*,34) iaz1,maz1,saz1
      write(*,35) iaz2,maz2,saz2
      write(*,32) edist,dmt
      write(*,*) '  '
      write(*,*) '  Do you want to save this output into a file (y/n)?'
      read(*,10) answer
c
      if( answer.eq.'Y'.or.answer.eq.'y' )then
   39   write(*,*) '  Enter the output filename : '
        read(*,40) filout
   40   format(a30)
        open(3,file=filout,status='new',err=99)
        goto 98
c
   99   write(*,*) '  File already exists, try again.'
        go to 39
c
   98   continue
        write(3,*) '  '
        write(3,49) elips
        finv=1.d0/f
        b=a*(1.d0-f)
        write(3,50) a,b,finv
        write(*,*) '  Enter the First Station name : '
        read(*,40) name1
        write(*,*) '  Enter the Second Station name : '
        read(*,40) name2
c
   41   format('  First  Station : ',a30)
   42   format('  Second Station : ',a30)
   84   format('  Error: First  Station ... Invalid Latitude  ')
   85   format('  Error: First  Station ... Invalid Longitude ')
   86   format('  Error: Second Station ... Invalid Latitude  ')
   87   format('  Error: Second Station ... Invalid Longitude ')
   88   format(1x,65(1h*))
   91   format('         DD(0-89) MM(0-59) SS(0-59.999...)  ')
   92   format('         DDD(0-359) MM(0-59) SS(0-59.999...)  ')
c
        write(3,*) '  '
        write(3,41) name1
        write(3,*) '  ---------------- '

        if( irlat1.eq.0 )then
          write(3,18) ld1, lm1, sl1, d_ns1
        else
          write(3,88)
          write(3,84)
          write(3,91)
          write(3,88)
        endif
c
        if( irlon1.eq.0 )then
          write(3,19) lod1,lom1,slo1,d_ew1
        else
          write(3,88)
          write(3,85)
          write(3,92)
          write(3,88)
        endif
c
        write(3,*) '  '
        write(3,42) name2
        write(3,*) '  ---------------- '
c
        if( irlat2.eq.0 )then
          write(3,18) ld2, lm2, sl2, d_ns2
        else
          write(3,88)
          write(3,86)
          write(3,91)
          write(3,88)
        endif
c
        if( irlon2.eq.0 )then
          write(3,19) lod2,lom2,slo2,d_ew2
        else
          write(3,88)
          write(3,87)
          write(3,92)
          write(3,88)
        endif
c
        write(3,*) '  '
        write(3,34) iaz1,maz1,saz1
        write(3,35) iaz2,maz2,saz2
        write(3,32) edist,dmt
        write(3,*) '  '
      endif
c
   80 write(*,*) '  '
      write(*,*) '  '
      write(*,*) '  '
      write(*,*) '  1) Another inverse, different ellipsoid.'
      write(*,*) '  2) Same ellipsoid, two new stations.'
      write(*,*) '  3) Same ellipsoid, same First Station.'
      write(*,*) '  4) Done.'
      write(*,*) '  '
      write(*,*) '  Enter choice : '
      read(*,10) answer
c
      if(     answer.eq.'1' )then
        goto 1
      elseif( answer.eq.'2' )then
        goto 15
      elseif( answer.eq.'3' )then
        goto 20
      else
        write(*,*) '  Thats all, folks!'
      endif

c     stop
      end


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2015 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine rectcyltrfm(node,co,cs,icntrl,fin,fout)
!
!     transforms a vector fin(1..3) in node "node" with coordinates
!     in co(1..3,node) from the global rectangular system into a local
!     cyclic symmetric cylindrical system or vice versa. The result
!     is stored in fout(1..3)
!
      implicit none
!
      integer node,icntrl,i
!
      real*8 co(3,*),cs(17,*),csab(7),fin(3),fout(3),a(3,3)
!
      do i=1,7
         csab(i)=cs(5+i,1)
      enddo
!
      if(icntrl.eq.2) then
!
!        global rectangular -> cylindrical
!
         call transformatrix(csab,co(1,node),a)
!
         fout(1)=fin(1)*a(1,1)+fin(2)*a(2,1)+fin(3)*a(3,1)
         fout(2)=fin(1)*a(1,2)+fin(2)*a(2,2)+fin(3)*a(3,2)
         fout(3)=fin(1)*a(1,3)+fin(2)*a(2,3)+fin(3)*a(3,3)
!
      elseif(icntrl.eq.-2) then
!
!        cylindrical -> global rectangular
!
         call transformatrix(csab,co(1,node),a)
!
         fout(1)=fin(1)*a(1,1)+fin(2)*a(1,2)+fin(3)*a(1,3)
         fout(2)=fin(1)*a(2,1)+fin(2)*a(2,2)+fin(3)*a(2,3)
         fout(3)=fin(1)*a(3,1)+fin(2)*a(3,2)+fin(3)*a(3,3)
!
      endif
!
      return
      end


      SUBROUTINE MBBSLJ (ARG,N,BSL)
C
C     SUBROUTINE TO COMPUTE EVEN ORDERED BESSEL FUNCTIONS OF FIRST KIND
C
C     UNDERFLOW MAY OCCUR IN THIS ROUTINE. THE RESULTS ARE NOT AFFECTED
C
      DIMENSION       BSL(4)
      CHARACTER       UFM*23,UWM*25,UIM*29,SFM*25
      COMMON /XMSSG / UFM,UWM,UIM,SFM
      COMMON /SYSTEM/ SYSBUF,N6
C
      DO 1 I = 1,20
    1 BSL(I) = 0.0
      ASQ = ARG**2
      IF (ASQ .LT. 0.01) GO TO 60
      N  = AMIN1(17.0,(ARG+10.0))
      F  = 2*N + 4
      BSL(N+3) = 0.0
      PF = (4.0*F*(F-1.0)/ASQ-(F-1.0)/F)*0.3
      IF (PF .LE. 1.E-08) GO TO 70
      BSL(N+2) = PF*1.E-30
      PF = 0.0
      J  = N + 1
      DO 10 I = 1,J
      M  = N - I + 2
      F  = 2*M + 1
      BSL(M) = ((4.*(F-1.)/ASQ-1./F-1./(F-2.))*BSL(M+1)-BSL(M+2)/F)*
     1         (F-2.0)
   10 PF = PF + 2.0*BSL(M+1)
      PF = PF + BSL(1)
      F  = 0.0
      IF (ABS(PF) .LE. 1.0) GO TO 20
      F  = ABS(PF)*1.E-10
   20 N  = N + 2
      DO 40 I = 1,N
      IF (F .GE. ABS(BSL(I))) BSL(I) = 0.0
      BSL(I) = BSL(I)/PF
   40 CONTINUE
      M  = N
      DO 50 I = 1,M
      IF (ABS(BSL(N)) .GT. 1.0E-07) RETURN
      N  = N - 1
   50 CONTINUE
      RETURN
C
   60 BSL(2) = 0.125*ASQ
      BSL(1) = 1.0 - 2.0*BSL(2)
      N  = 2
      GO TO 90
C
   70 CALL PAGE2 (3)
      WRITE  (N6,80) SFM,ARG
   80 FORMAT (A25,' 2435, MBBSLJ SUBROUTINE FAILED BECAUSE THE ARGUMEN',
     1       'T IS TOO LARGE FOR THE BSL ARRAY', /5X,'ARG =',1P,E13.5)
      CALL MESAGE (-61,0,0)
   90 RETURN
      END


      subroutine FACENODEBC(
     &           state
     &           ,istatelo0
     &           ,istatehi0
     &           ,nstatecomp
     &           ,neumfac
     &           ,ineumfaclo0
     &           ,ineumfachi0
     &           ,nneumfaccomp
     &           ,dircfac
     &           ,idircfaclo0
     &           ,idircfachi0
     &           ,ndircfaccomp
     &           ,inhmval
     &           ,iinhmvallo0
     &           ,iinhmvalhi0
     &           ,ninhmvalcomp
     &           ,ifaceboxlo0
     &           ,ifaceboxhi0
     &           ,idir
     &           ,side
     &           ,dx
     &           ,startcomp
     &           ,endcomp
     &           )
      implicit none
      integer*8 ch_flops
      COMMON/ch_timer/ ch_flops
      integer CHF_ID(0:5,0:5)
      data CHF_ID/ 1,0,0,0,0,0 ,0,1,0,0,0,0 ,0,0,1,0,0,0 ,0,0,0,1,0,0 ,0
     &,0,0,0,1,0 ,0,0,0,0,0,1 /
      integer nstatecomp
      integer istatelo0
      integer istatehi0
      REAL*8 state(
     &           istatelo0:istatehi0,
     &           0:nstatecomp-1)
      integer nneumfaccomp
      integer ineumfaclo0
      integer ineumfachi0
      REAL*8 neumfac(
     &           ineumfaclo0:ineumfachi0,
     &           0:nneumfaccomp-1)
      integer ndircfaccomp
      integer idircfaclo0
      integer idircfachi0
      REAL*8 dircfac(
     &           idircfaclo0:idircfachi0,
     &           0:ndircfaccomp-1)
      integer ninhmvalcomp
      integer iinhmvallo0
      integer iinhmvalhi0
      REAL*8 inhmval(
     &           iinhmvallo0:iinhmvalhi0,
     &           0:ninhmvalcomp-1)
      integer ifaceboxlo0
      integer ifaceboxhi0
      integer idir
      integer side
      REAL*8 dx
      integer startcomp
      integer endcomp
      REAL*8 nfac, dfac, ival, sval,denom,numer
      integer ncomp,nc
      integer i0, ii0
      ncomp = nstatecomp
      if(ncomp .ne. nneumfaccomp) then
          call MAYDAY_ERROR()
      endif
      if(ncomp .ne. ndircfaccomp) then
          call MAYDAY_ERROR()
      endif
      if(ncomp .ne. ninhmvalcomp) then
          call MAYDAY_ERROR()
      endif
      if ((side .ne. -1) .and. (side .ne. 1)) then
          call MAYDAY_ERROR()
      endif
      ii0= side*CHF_ID(0, idir)
      do nc = startcomp, endcomp
      do i0 = ifaceboxlo0,ifaceboxhi0
              nfac = neumfac(i0, nc)
              dfac = dircfac(i0, nc)
              ival = inhmval(i0, nc)
              sval = state(i0-ii0, nc)
              denom = dfac + side*(nfac/dx)
              numer = ival + side*(nfac/dx)*sval
              state(i0, nc) = numer/denom
      enddo
      enddo
      return
      end


      SUBROUTINE MB03JZ( COMPQ, N, A, LDA, D, LDD, B, LDB, F, LDF, Q,
     $                   LDQ, NEIG, TOL, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To move the eigenvalues with strictly negative real parts of an
C     N-by-N complex skew-Hamiltonian/Hamiltonian pencil aS - bH in
C     structured Schur form to the leading principal subpencil, while
C     keeping the triangular form. On entry, we have
C
C           (  A  D  )      (  B  F  )
C       S = (        ), H = (        ),
C           (  0  A' )      (  0 -B' )
C
C     where A and B are upper triangular.
C     S and H are transformed by a unitary matrix Q such that
C
C                            (  Aout  Dout  )
C       Sout = J Q' J' S Q = (              ), and
C                            (    0   Aout' )
C                                                                    (1)
C                            (  Bout  Fout  )           (  0  I  )
C       Hout = J Q' J' H Q = (              ), with J = (        ),
C                            (    0  -Bout' )           ( -I  0  )
C
C     where Aout and Bout remain in upper triangular form. The notation
C     M' denotes the conjugate transpose of the matrix M.
C     Optionally, if COMPQ = 'I' or COMPQ = 'U', the unitary matrix Q
C     that fulfills (1) is computed.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     COMPQ   CHARACTER*1
C             Specifies whether or not the unitary transformations
C             should be accumulated in the array Q, as follows:
C             = 'N':  Q is not computed;
C             = 'I':  the array Q is initialized internally to the unit
C                     matrix, and the unitary matrix Q is returned;
C             = 'U':  the array Q contains a unitary matrix Q0 on
C                     entry, and the matrix Q0*Q is returned, where Q
C                     is the product of the unitary transformations
C                     that are applied to the pencil aS - bH to reorder
C                     the eigenvalues.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the pencil aS - bH.  N >= 0, even.
C
C     A       (input/output) COMPLEX*16 array, dimension (LDA, N/2)
C             On entry, the leading N/2-by-N/2 part of this array must
C             contain the upper triangular matrix A.
C             On exit, the leading  N/2-by-N/2 part of this array
C             contains the transformed matrix Aout.
C             The strictly lower triangular part of this array is not
C             referenced.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= MAX(1, N/2).
C
C     D       (input/output) COMPLEX*16 array, dimension (LDD, N/2)
C             On entry, the leading N/2-by-N/2 part of this array must
C             contain the upper triangular part of the skew-Hermitian
C             matrix D.
C             On exit, the leading  N/2-by-N/2 part of this array
C             contains the transformed matrix Dout.
C             The strictly lower triangular part of this array is not
C             referenced.
C
C     LDD     INTEGER
C             The leading dimension of the array D.  LDD >= MAX(1, N/2).
C
C     B       (input/output) COMPLEX*16 array, dimension (LDB, N/2)
C             On entry, the leading N/2-by-N/2 part of this array must
C             contain the upper triangular matrix B.
C             On exit, the leading  N/2-by-N/2 part of this array
C             contains the transformed matrix Bout.
C             The strictly lower triangular part of this array is not
C             referenced.
C
C     LDB     INTEGER
C             The leading dimension of the array B.  LDB >= MAX(1, N/2).
C
C     F       (input/output) COMPLEX*16 array, dimension (LDF, N/2)
C             On entry, the leading N/2-by-N/2 part of this array must
C             contain the upper triangular part of the Hermitian matrix
C             F.
C             On exit, the leading  N/2-by-N/2 part of this array
C             contains the transformed matrix Fout.
C             The strictly lower triangular part of this array is not
C             referenced.
C
C     LDF     INTEGER
C             The leading dimension of the array F.  LDF >= MAX(1, N/2).
C
C     Q       (input/output) COMPLEX*16 array, dimension (LDQ, N)
C             On entry, if COMPQ = 'U', then the leading N-by-N part of
C             this array must contain a given matrix Q0, and on exit,
C             the leading N-by-N part of this array contains the product
C             of the input matrix Q0 and the transformation matrix Q
C             used to transform the matrices S and H.
C             On exit, if COMPQ = 'I', then the leading N-by-N part of
C             this array contains the unitary transformation matrix Q.
C             If COMPQ = 'N' this array is not referenced.
C
C     LDQ     INTEGER
C             The leading dimension of the array Q.
C             LDQ >= 1,         if COMPQ = 'N';
C             LDQ >= MAX(1, N), if COMPQ = 'I' or COMPQ = 'U'.
C
C     NEIG    (output) INTEGER
C             The number of eigenvalues in aS - bH with strictly
C             negative real part.
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             The tolerance used to decide the sign of the eigenvalues.
C             If the user sets TOL > 0, then the given value of TOL is
C             used. If the user sets TOL <= 0, then an implicitly
C             computed, default tolerance, defined by MIN(N,10)*EPS, is
C             used instead, where EPS is the machine precision (see
C             LAPACK Library routine DLAMCH). A larger value might be
C             needed for pencils with multiple eigenvalues.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0: succesful exit;
C             < 0: if INFO = -i, the i-th argument had an illegal value.
C
C     METHOD
C
C     The algorithm reorders the eigenvalues like the following scheme:
C
C     Step 1: Reorder the eigenvalues in the subpencil aA - bB.
C          I. Reorder the eigenvalues with negative real parts to the
C             top.
C         II. Reorder the eigenvalues with positive real parts to the
C             bottom.
C
C     Step 2: Reorder the remaining eigenvalues with negative real parts.
C          I. Exchange the eigenvalues between the last diagonal block
C             in aA - bB and the last diagonal block in aS - bH.
C         II. Move the eigenvalues in the N/2-th place to the (MM+1)-th
C             place, where MM denotes the current number of eigenvalues
C             with negative real parts in aA - bB.
C
C     The algorithm uses a sequence of unitary transformations as
C     described on page 43 in [1]. To achieve those transformations the
C     elementary SLICOT Library subroutines MB03DZ and MB03HZ are called
C     for the corresponding matrix structures.
C
C     REFERENCES
C
C     [1] Benner, P., Byers, R., Mehrmann, V. and Xu, H.
C         Numerical Computation of Deflating Subspaces of Embedded
C         Hamiltonian Pencils.
C         Tech. Rep. SFB393/99-15, Technical University Chemnitz,
C         Germany, June 1999.
C
C     NUMERICAL ASPECTS
C                                                               3
C     The algorithm is numerically backward stable and needs O(N )
C     complex floating point operations.
C
C     CONTRIBUTOR
C
C     Matthias Voigt, Fakultaet fuer Mathematik, Technische Universitaet
C     Chemnitz, April 6, 2009.
C     V. Sima, Aug. 2009 (SLICOT version of the routine ZHAUNX).
C
C     REVISIONS
C
C     V. Sima, Dec. 2010, Jan. 2011, Aug. 2014.
C     M. Voigt, Jan. 2012.
C
C     KEYWORDS
C
C     Eigenvalue reordering, upper triangular matrix,
C     skew-Hamiltonian/Hamiltonian pencil, structured Schur form.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, TEN
      PARAMETER          ( ZERO = 0.0D+0, TEN = 1.0D+1 )
      COMPLEX*16         CZERO, CONE
      PARAMETER          ( CZERO = ( 0.0D+0, 0.0D+0 ), CONE = ( 1.0D+0,
     $                     0.0D+0 ) )
C
C     .. Scalar Arguments ..
      CHARACTER          COMPQ
      INTEGER            INFO, LDA, LDB, LDD, LDF, LDQ, N, NEIG
      DOUBLE PRECISION   TOL
C
C     .. Array Arguments ..
      COMPLEX*16         A( LDA, * ), B( LDB, * ), D( LDD, * ),
     $                   F( LDF, * ), Q( LDQ, * )
C
C     .. Local Scalars ..
      LOGICAL            LCMPQ, LINIQ, LUPDQ
      INTEGER            IUPD, J, K, M, MM, MP, UPDS
      DOUBLE PRECISION   CO1, CO2, EPS
      COMPLEX*16         CJF, SI1, SI2, TMP
C
C     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           DLAMCH, LSAME
C
C     .. External Subroutines ..
      EXTERNAL           MB03DZ, MB03HZ, XERBLA, ZLASET, ZROT
C
C     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, DCONJG, DIMAG, MAX, MIN, MOD
C
C     .. Executable Statements ..
C
C     Decode the input arguments.
C
      M     = N/2
      NEIG  = 0
      LINIQ = LSAME( COMPQ, 'I' )
      LUPDQ = LSAME( COMPQ, 'U' )
      LCMPQ = LINIQ .OR. LUPDQ
C
C     Test the input arguments.
C
      INFO = 0
      IF( .NOT.( LSAME( COMPQ, 'N' ) .OR. LCMPQ ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 .OR. MOD( N, 2 ).NE.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -4
      ELSE IF( LDD.LT.MAX( 1, M ) ) THEN
         INFO = -6
      ELSE IF( LDB.LT.MAX( 1, M ) ) THEN
         INFO = -8
      ELSE IF( LDF.LT.MAX( 1, M ) ) THEN
         INFO = -10
      ELSE IF( LDQ.LT.1 .OR. ( LCMPQ .AND. LDQ.LT.N ) ) THEN
         INFO = -12
      END IF
      IF( INFO.NE.0) THEN
         CALL XERBLA( 'MB03JZ', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( N.EQ.0 )
     $   RETURN
C
      EPS = TOL
      IF ( EPS.LE.ZERO ) THEN
C
C        Use the default tolerance.
C
         EPS = MIN( DBLE( N ), TEN )*DLAMCH( 'Precision' )
      END IF
C
C     STEP 0. Initializations.
C
      IF( LINIQ ) THEN
         IUPD = M + 1
         UPDS = M
         CALL ZLASET( 'Full', N, N, CZERO, CONE, Q, LDQ )
      ELSE IF( LUPDQ ) THEN
         IUPD = 1
         UPDS = N
      END IF
C
C     STEP 1. Reorder the eigenvalues in the subpencil aA - bB.
C
      MM = 0
      MP = M + 1
C
C     I. Reorder the eigenvalues with negative real parts to the top.
C
      DO 20 K = 1, M
         IF( DBLE(  A( K, K ) )*DBLE(  B( K, K ) ) +
     $       DIMAG( A( K, K ) )*DIMAG( B( K, K ) ).LT.
     $       -ABS(  A( K, K ) )*ABS(   B( K, K ) )*EPS ) THEN
C
            DO 10 J = K - 1, MM + 1, -1
C
C              Perform eigenvalue exchange.
C
               CALL MB03DZ( A( J, J ), LDA, B( J, J ), LDB, CO1, SI1,
     $                      CO2, SI2 )
C
C              Update A and D.
C
               CALL ZROT( J, A( 1, J+1 ), 1, A( 1, J ), 1, CO1, SI1 )
               A( J, J )     = CO2*A( J, J ) +
     $                         SI2*A( J+1, J+1 )*DCONJG( SI1 )
               A( J+1, J+1 ) = CO1*A( J+1, J+1 )
               CALL ZROT( M-J, A( J, J+1 ), LDA, A( J+1, J+1 ), LDA,
     $                    CO2, -SI2 )
C
               CJF = -DCONJG( D( J, J+1 ) )
               TMP = CO2*CJF - DCONJG( SI2 )*D( J+1, J+1 )
               CALL ZROT( J, D( 1, J+1 ), 1, D( 1, J ), 1, CO2, SI2 )
               D( J, J )     = CO2*D( J, J )     - SI2*TMP
               D( J+1, J+1 ) = CO2*D( J+1, J+1 ) + SI2*CJF
               CALL ZROT( M-J, D( J, J+1 ), LDD, D( J+1, J+1 ), LDD,
     $                    CO2, -SI2 )
C
C              Update B and F.
C
               CALL ZROT( J, B( 1, J+1 ), 1, B( 1, J ), 1, CO1, SI1 )
               B( J, J )     = CO2*B( J, J ) +
     $                         SI2*B( J+1, J+1 )*DCONJG( SI1 )
               B( J+1, J+1 ) = CO1*B( J+1, J+1 )
               CALL ZROT( M-J, B( J, J+1 ), LDB, B( J+1, J+1 ), LDB,
     $                    CO2, -SI2 )
C
               CJF = DCONJG( F( J, J+1 ) )
               TMP = CO2*CJF - DCONJG( SI2 )*F( J+1, J+1 )
               CALL ZROT( J, F( 1, J+1 ), 1, F( 1, J ), 1, CO2, SI2 )
               F( J, J )     = CO2*F( J, J )     - SI2*TMP
               F( J+1, J+1 ) = CO2*F( J+1, J+1 ) + SI2*CJF
               CALL ZROT( M-J, F( J, J+1 ), LDF, F( J+1, J+1 ), LDF,
     $                    CO2, -SI2 )
C
               IF( LCMPQ ) THEN
C
C                 Update Q.
C
                  CALL ZROT( UPDS, Q( 1, J+1 ), 1, Q( 1, J ), 1, CO1,
     $                       SI1 )
                  CALL ZROT( UPDS, Q( IUPD, M+J+1 ), 1, Q( IUPD, M+J ),
     $                       1, CO2, SI2 )
               END IF
   10       CONTINUE
            MM = MM + 1
         END IF
   20 CONTINUE
C
C     II. Reorder the eigenvalues with positive real parts to the bottom.
C
      DO 40 K = M, MM + 1, -1
         IF( DBLE(  A( K, K ) )*DBLE(  B( K, K ) ) +
     $       DIMAG( A( K, K ) )*DIMAG( B( K, K ) ).GT.
     $       ABS(   A( K, K ) )*ABS(   B( K, K ) )*EPS ) THEN
C
            DO 30 J = K, MP - 2
C
C              Perform eigenvalue exchange.
C
               CALL MB03DZ( A( J, J ), LDA, B( J, J ), LDB, CO1, SI1,
     $                      CO2, SI2 )
C
C              Update A and D.
C
               CALL ZROT( J, A( 1, J+1 ), 1, A( 1, J ), 1, CO1, SI1 )
               A( J, J )     = CO2*A( J, J ) +
     $                         SI2*A( J+1, J+1 )*DCONJG( SI1 )
               A( J+1, J+1 ) = CO1*A( J+1, J+1 )
               CALL ZROT( M-J, A( J, J+1 ), LDA, A( J+1, J+1 ), LDA,
     $                    CO2, -SI2 )
C
               CJF = -DCONJG( D( J, J+1 ) )
               TMP = CO2*CJF - DCONJG( SI2 )*D( J+1, J+1 )
               CALL ZROT( J, D( 1, J+1 ), 1, D( 1, J ), 1, CO2, SI2 )
               D( J, J )     = CO2*D( J, J )     - SI2*TMP
               D( J+1, J+1 ) = CO2*D( J+1, J+1 ) + SI2*CJF
               CALL ZROT( M-J, D( J, J+1 ), LDD, D( J+1, J+1 ), LDD,
     $                    CO2, -SI2 )
C
C              Update B and F.
C
               CALL ZROT( J, B( 1, J+1 ), 1, B( 1, J ), 1, CO1, SI1 )
               B( J, J )     = CO2*B( J, J ) +
     $                         SI2*B( J+1, J+1 )*DCONJG( SI1 )
               B( J+1, J+1 ) = CO1*B( J+1, J+1 )
               CALL ZROT( M-J, B( J, J+1 ), LDB, B( J+1, J+1 ), LDB,
     $                    CO2, -SI2 )
C
               CJF = DCONJG( F( J, J+1 ) )
               TMP = CO2*CJF - DCONJG( SI2 )*F( J+1, J+1 )
               CALL ZROT( J, F( 1, J+1 ), 1, F( 1, J ), 1, CO2, SI2 )
               F( J, J )     = CO2*F( J, J )     - SI2*TMP
               F( J+1, J+1 ) = CO2*F( J+1, J+1 ) + SI2*CJF
               CALL ZROT( M-J, F( J, J+1 ), LDF, F( J+1, J+1 ), LDF,
     $                    CO2, -SI2 )
C
               IF( LCMPQ ) THEN
C
C                 Update Q.
C
                  CALL ZROT( UPDS, Q( 1, J+1 ), 1, Q( 1, J ), 1, CO1,
     $                       SI1 )
                  CALL ZROT( UPDS, Q( IUPD, M+J+1 ), 1, Q( IUPD, M+J ),
     $                       1, CO2, SI2 )
               END IF
   30       CONTINUE
            MP = MP - 1
         END IF
   40 CONTINUE
C
C     The remaining M-MP+1 eigenvalues with negative real part are now in
C     the bottom right subpencil of aS - bH.
C
C     STEP 2. Reorder the remaining M-MP+1 eigenvalues.
C
      DO 60 K = M, MP, -1
C
C        I. Exchange the eigenvalues between two diagonal blocks.
C
C        Perform eigenvalue exchange.
C
         CALL MB03HZ( A( M, M ), D( M, M ), B( M, M ), F( M, M ), CO1,
     $                SI1 )
C
C        Update A and D.
C
         TMP = DCONJG( A( M, M ) )
         CALL ZROT( M, D( 1, M ), 1, A( 1, M ), 1, CO1, SI1 )
         A( M, M ) = A( M, M )*CO1 + TMP*DCONJG( SI1 )**2
         D( M, M ) = D( M, M )*CO1 - TMP*DCONJG( SI1 )*CO1
C
C        Update B and F.
C
         TMP = -DCONJG( B( M, M ) )
         CALL ZROT( M, F( 1, M ), 1, B( 1, M ), 1, CO1, SI1 )
         B( M, M ) = B( M, M )*CO1 + TMP*DCONJG( SI1 )**2
         F( M, M ) = F( M, M )*CO1 - TMP*DCONJG( SI1 )*CO1
C
         IF( LCMPQ ) THEN
C
C           Update Q.
C
            CALL ZROT( N, Q( 1, N ), 1, Q( 1, M ), 1, CO1, SI1 )
         END IF
C
C        II. Move the eigenvalue in the M-th diagonal position to the
C            (MM+1)-th position.
C
         MM = MM + 1
         DO 50 J = M - 1, MM, -1
C
C           Perform eigenvalue exchange.
C
            CALL MB03DZ( A( J, J ), LDA, B( J, J ), LDB, CO1, SI1, CO2,
     $                   SI2 )
C
C           Update A and D.
C
            CALL ZROT( J, A( 1, J+1 ), 1, A( 1, J ), 1, CO1, SI1 )
            A( J, J )     = CO2*A( J, J ) +
     $                      SI2*A( J+1, J+1 )*DCONJG( SI1 )
            A( J+1, J+1 ) = CO1*A( J+1, J+1 )
            CALL ZROT( M-J, A( J, J+1 ), LDA, A( J+1, J+1 ), LDA, CO2,
     $                 -SI2 )
C
            CJF = -DCONJG( D( J, J+1 ) )
            TMP = CO2*CJF - DCONJG( SI2 )*D( J+1, J+1 )
            CALL ZROT( J, D( 1, J+1 ), 1, D( 1, J ), 1, CO2, SI2 )
            D( J, J )     = CO2*D( J, J )     - SI2*TMP
            D( J+1, J+1 ) = CO2*D( J+1, J+1 ) + SI2*CJF
            CALL ZROT( M-J, D( J, J+1 ), LDD, D( J+1, J+1 ), LDD, CO2,
     $                 -SI2 )
C
C           Update B and F.
C
            CALL ZROT( J, B( 1, J+1 ), 1, B( 1, J ), 1, CO1, SI1 )
            B( J, J )     = CO2*B( J, J ) +
     $                      SI2*B( J+1, J+1 )*DCONJG( SI1 )
            B( J+1, J+1 ) = CO1*B( J+1, J+1 )
            CALL ZROT( M-J, B( J, J+1 ), LDB, B( J+1, J+1 ), LDB, CO2,
     $                 -SI2 )
C
            CJF = DCONJG( F( J, J+1 ) )
            TMP = CO2*CJF - DCONJG( SI2 )*F( J+1, J+1 )
            CALL ZROT( J, F( 1, J+1 ), 1, F( 1, J ), 1, CO2, SI2 )
            F( J, J )     = CO2*F( J, J )     - SI2*TMP
            F( J+1, J+1 ) = CO2*F( J+1, J+1 ) + SI2*CJF
            CALL ZROT( M-J, F( J, J+1 ), LDF, F( J+1, J+1 ), LDF, CO2,
     $                 -SI2 )
C
            IF( LCMPQ ) THEN
C
C              Update Q.
C
               CALL ZROT( N, Q( 1, J+1 ), 1, Q( 1, J ), 1, CO1, SI1 )
               CALL ZROT( N, Q( 1, M+J+1 ), 1, Q( 1, M+J ), 1, CO2, SI2
     $                     )
            END IF
   50    CONTINUE
   60 CONTINUE
C
      NEIG = MM
C
      RETURN
C *** Last line of MB03JZ ***
      END


       subroutine DAZEL1
C#  SUB DAZEL1                 Same as CALL DAZEL(1)
       IMPLICIT DOUBLE PRECISION(A-L,N-Y)
C
C     TWO MODES--   0   INPUT LAT AND LON OF END POINT
C                       RETURN DISTANCE AND AZIMUTH TO END PT WITH ELEVATIONS
C                   1   INPUT BEARING (AZIMUTH) OF END POINT
C                       RETURN LAT AND LON OF END POINT WITH ELEVATIONS
C
C   MODE 0
C   INPUT PARAMETERS (THESE DEFINE LOCATION OF POINTS T (TRANSMITTER)
C     AND R (RECEIVER) RELATIVE TO A SPHERICAL EARTH.
C     ZTLAT - LATITUDE (DECIMAL DEGREES NORTH OF EQUATOR) OF POINT T
C     ZTLON - LONGITUDE (DECIMAL DEGREES EAST OF PRIME (GREENWICH)
C            MERIDIAN) OF POINT T
C     ZTHT  - HEIGHT (METERS ABOVE MEAN SEA LEVEL) OF POINT T
C     ZRLAT - LATITUDE (DECIMAL DEGREES NORTH OF EQUATOR) OF POINT R
C     ZRLON - LONGITUDE (DECIMAL DEGREES EAST OF PRIME MERIDIAN OF POINT R
C     ZRHT  - HEIGHT (METERS ABOVE MEAN SEA LEVEL) OF POINT R
C
C   OUTPUT PARAMETERS
C     ZTAZ  - AZUMUTH (DECIMAL DEGREES CLOCKWISE FROM NORTH) AT T OF R
C     ZRAZ  - AZIMUTH (DECIMAL DEGREES CLOCKWISE FROM NORTH) AT R OF T
C     ZTELV - ELEVATION ANGLE (DECIMAL DEGREES ABOVE HORIZONTAL AT T
C            OF STRAIGHT LINE BETWEEN T AND R
C     ZRELV - ELEVATION ANGLE (DECIMAL DEGREES ABOVE HORIZONTAL AT R)
C            OF STRAIGHT LINE BETWEEN T AND R
C     ZTAKOF - TAKE-OFF ANGLE (DECIMAL DEGREES ABOVE HORIZONTAL AT T)
C            OF REFRACTED RAY BETWEEN T AND R (ASSUMED 4/3 EARTH RADIUS)
C     ZRAKOF - TAKE-OFF ANGLE (DECIMAL DEGREES ABOVE HORIZONTAL AT R)
C            OF REFRACTED RAY BETWEEN T AND R (ASSUMED 4/3 EARTH RADIUS)
C     ZD    - STRAIGHT LINE DISTANCE (KILOMETERS) BETWEEN T AND R
C     ZDGC  - GREAT CIRCLE DISTANCE (KILOMETERS) BETWEEN T AND R
C
C   MODE 1
C   INPUT PARAMETERS                    OUTPUT PARAMETERS
C     ZTLAT                                ZRLAT
C     ZTLON                                ZRLON
C     ZTAZ                                 RELEV,ZRAKOF
C     ZDGC                                 TELEV,ZTAKOF
C
C
C     ALL OF THE ABOVE PARAMETERS START WITH THE LETTER Z AND ARE SINGLE
C     PRECISION.  ALL PROGRAM VARIABLES ARE DOUBLE PRECISION.
C     PROGRAM IS UNPREDICTABLE FOR SEPARATIONS LESS THAN 0.00005 DEGREES,
C     ABOUT 5 METERS.
C
C   WRITTEN BY KEN SPIES 5/79
C   REFRACTION AND ST. LINE ELEVATIONS BY EJH
C
      COMMON/AZEL/ ZTLAT,ZTLON,ZTHT,ZRLAT,ZRLON,ZRHT,ZTAZ,ZRAZ,
     * ZTELV,ZRELV,ZD,ZDGC,ZTAKOF,ZRAKOF
      DATA PI/3.141592653589793238462643D0/,RERTH/6370.0D0/
      DATA DTOR/0.01745329252D0/,RTOD/57.29577951D0/
C
C     COMPUTE END POINT GIVEN DISTANCE AND BEARING
C
200   TLATR=ZTLAT*DTOR
      TLONR=ZTLON*DTOR
      TAZR=ZTAZ*DTOR
      GC=ZDGC/RERTH
      COLAT=PI/2.0 - TLATR
      COSCO=DCOS(COLAT)
      SINCO=DSIN(COLAT)
      COSGC=DCOS(GC)
      SINGC=DSIN(GC)
      COSB=COSCO*COSGC + SINCO*SINGC*DCOS(TAZR)
      ARG=DMAX1(0.0D0,(1.0D0-COSB*COSB))
      B=DATAN2(DSQRT(ARG),COSB)
      ARC=(COSGC-COSCO*COSB)/(SINCO*DSIN(B))
      ARG=DMAX1(0.0D0,(1.0D0-ARC*ARC))
      RDLON=DATAN2(DSQRT(ARG),ARC)
      ZRLAT=(PI/2.0 - DABS(B))*RTOD
      DRLAT=ZRLAT
      ZRLAT=DSIGN(DRLAT,COSB)
      ZRLON=ZTLON+(DABS(RDLON)*RTOD)
      IF(ZTAZ .GT. 180) ZRLON=ZTLON-(DABS(RDLON)*RTOD)
      THTS=ZTHT*1.0E-3
      RHTS=ZRHT*1.0E-3
      DELHT=RHTS-THTS
      SGC=DSIN(0.5*GC)
      D=DSQRT(DELHT*DELHT+4.0*(RERTH+THTS)*(RERTH+RHTS)*SGC*SGC)
C
C   COMPUTE GREAT CIRCLE DISTANCE AND ELEVATION ANGLES
C
       IF(DELHT .GE. 0) GOTO 145
       AHT=THTS
       BHT=RHTS
       GO TO 150
145    AHT=RHTS
       BHT=THTS
150    SAELV=0.5*(D*D+DABS(DELHT)*(RERTH+AHT+RERTH+BHT))/(D*(RERTH+AHT))
      ARG=DMAX1(0.0001D0,(1.0D0-SAELV*SAELV))
       AELV=DATAN2(SAELV,DSQRT(ARG))
       BELV=(AELV-GC)*RTOD
       AELV=-AELV*RTOD
C   COMPUTE TAKE-OFF ANGLES ASSUMING 4/3 EARTH RADIUS
       R4THD=RERTH*4.0/3.0
       GC=0.75*GC
       SGC=DSIN(0.5*GC)
       P=2.0*SGC*SGC
       AALT=R4THD+AHT
       BALT=R4THD+BHT
       DA=DSQRT(DELHT*DELHT+2.0*AALT*BALT*P)
       SAELV=0.5*(DA*DA+DABS(DELHT)*(AALT+BALT))/(DA*AALT)
      ARG=DMAX1(0.0001D0,(1.0D0-SAELV*SAELV))
       ATAKOF=DATAN(SAELV/DSQRT(ARG))
       BTAKOF=(ATAKOF-GC)*RTOD
       ATAKOF=-ATAKOF*RTOD
       IF(DELHT-0.0)151,155,155
151    ZTELV=AELV
       ZRELV=BELV
       ZTAKOF=ATAKOF
       ZRAKOF=BTAKOF
       RETURN
155    ZTELV=BELV
       ZRELV=AELV
       ZTAKOF=BTAKOF
       ZRAKOF=ATAKOF
       RETURN
      END
C------------------------------------------------------------------


!Author:Huang Yihan
!This module is used to calculate this problem
module calculate_mod
    use input_mod
    use table_mod
    implicit none
    real*8                  :: alpha(2)
    real*8                  :: beta(2)
    real*8                  :: sigmae
    integer*4               :: ii
    real*8                  :: sigma0(2)
    real*8                  :: ieff(2)
    real*8                  :: xseff(N2)
    integer*4               :: kk
    integer*4               :: jj
    contains
    !==========================================
    !<This subroutine is used to calculate sigmae
        subroutine calculate_sigmae(radius,sigmae)
            real*8,intent(in)     ::radius
            real*8,intent(inout)  ::sigmae
            sigmae=1/(2*radius)
        end subroutine calculate_sigmae
    !==========================================
    !<This subroutine is used to calculate alpha and beta,
    !<You should get a dancoff to subroutine
        subroutine calculate_ab(dancoff,alpha1,alpha2,beta1,beta2)
            real*8,intent(in)     :: dancoff
            real*8,intent(inout)  :: alpha1
            real*8,intent(inout)  :: alpha2
            real*8,intent(inout)  :: beta1
            real*8,intent(inout)  :: beta2
            real*8                :: A
            A=(1-dancoff)/dancoff
            alpha1=((5*A+6)-sqrt(A*A+36*A+36))/(2*(A+1))
            alpha2=((5*A+6)+sqrt(A*A+36*A+36))/(2*(A+1))
            beta1=((4*A+6)/(A+1)-alpha1)/(alpha2-alpha1)
            beta2=1-beta1
        end subroutine calculate_ab
    !===========================================
    !This subroutine is used to calculate sigma0
        subroutine calculate_sigma0(n,sigmae,density,sigma0,k)
            integer*4,intent(in)                           :: n
            real*8,intent(in)                              :: sigmae
            real*8,intent(in)                              :: density
            real*8,intent(inout)                           :: sigma0
            integer*4,intent(in)                           :: k
            sigma0=(group(n)%H1XSP*density_H1+alpha(k)*sigmae)/density
        end subroutine calculate_sigma0
    !===========================================
    !This subroutine is used to calculate Ieff
        subroutine calculate_i(i1,i2,i)
            real*8,intent(in)                              :: i1
            real*8,intent(in)                              :: i2
            real*8,intent(inout)                           :: i
            i=beta(1)*i1+beta(2)*i2
        end subroutine calculate_i
    !===========================================
    !This subroutine is used to calculate Xseff
        subroutine calculate_xseff(i1,i2,sigma01,sigma02,xseff)
            real*8,intent(in)                              :: i1
            real*8,intent(in)                              :: i2
            real*8,intent(in)                              :: sigma01
            real*8,intent(in)                              :: sigma02
            real*8,intent(inout)                           :: xseff
            xseff=(beta(1)*i1+beta(2)*i2)/(1-(beta(1)*i1/(group(ii)%U8XSP+sigma01))&
            -(beta(2)*i2/(group(ii)%U8XSP+sigma02)))
        end subroutine calculate_xseff
    !===========================================
    !This subroutine is the main subroutine to calculate Xseff
        subroutine calculate_xs
            do jj=1,2
                call calculate_ab(dancoff(jj),alpha(1),alpha(2),beta(1),beta(2))
                do ii=1,N2
                    do kk=1,2
                        call calculate_sigma0(ii,sigmae,density_U8,sigma0(kk),kk)
                        call interpole(ii+N1,293.0,sigma0(kk),ieff(kk))
                    end do
                    call calculate_xseff(ieff(1),ieff(2),sigma0(1),sigma0(2),xseff(ii))
                end do
                call write_xseff
            end do
        end subroutine calculate_xs
    !============================================
    !This subroutine is used to write results
        subroutine write_xseff
            write(*,*) 'pin=',jj
            write(*,*) 'Group  High Boundary Low Boundary  Xs_absorb'
            do ii=1,N2
                write(*,'(2x,I2,4x,Es10.4,4x,Es10.4,4x,Es12.6)') ii+N1,group(ii)%high_boundary,group(ii)%low_boundary,xseff(ii)
            end do
        end subroutine write_xseff
end module calculate_mod


      module geolib
      real*8 ,parameter :: geoini(3,4)=
     $     reshape(
     $     (/0.d0,-1.d0, 0.d0,
     $       0.d0, 0.d0,-1.d0,
     $       1.d0, 0.d0, 0.d0,
     $       0.d0, 0.d0, 0.d0/) , (/3,4/))

      contains
      real*8 function tfchi(geo,i)
      implicit none
      real*8 , intent(in)::geo(3,3)
      integer*4 ,intent(in):: i
      if(i .eq. 2)then
        tfchi=asin(geo(3,3))
      elseif(i .eq. 1)then
        if(geo(2,3) .eq. 0.d0)then
          tfchi=0.d0
        else
          tfchi=atan(geo(2,3),geo(1,3))
        endif
      else
        if(geo(3,1) .eq. 0.d0)then
          tfchi=0.d0
        else
          tfchi=atan(geo(3,1),-geo(3,2))
        endif
      endif
      return
      end function

      real*8 function tfchitogeo(chi) result(geo)
      implicit none
      real*8 , intent(in)::chi(3)
      dimension geo(3,3)
      real*8 schi1,cchi1,schi2,cchi2,schi3,cchi3
      cchi1=cos(chi(1))
      cchi2=cos(chi(2))
      cchi3=cos(chi(3))
      schi1=sin(chi(1))
      schi2=sin(chi(2))
      schi3=sin(chi(3))
      geo(1,1)= schi1*cchi3-cchi1*schi2*schi3
      geo(2,1)=-cchi1*cchi3-schi1*schi2*schi3
      geo(3,1)= cchi2*schi3
      geo(1,2)= schi1*schi3+cchi1*schi2*cchi3
      geo(2,2)=-cchi1*schi3+schi1*schi2*cchi3
      geo(3,2)=-cchi2*cchi3
      geo(1,3)= cchi1*cchi2
      geo(2,3)= schi1*cchi2
      geo(3,3)= schi2
      return
      end function

      real*8 function tfchitorot(chi) result(rot)
      implicit none
      real*8 , intent(in)::chi(3)
      dimension rot(3,3)
      real*8 schi1,cchi1,schi2,cchi2,schi3,cchi3
      cchi1=cos(chi(1))
      cchi2=cos(chi(2))
      cchi3=cos(chi(3))
      schi1=sin(chi(1))
      schi2=sin(chi(2))
      schi3=sin(chi(3))
      rot(1,1)= cchi1*cchi2
      rot(2,1)= cchi2*schi1
      rot(3,1)= schi2
      rot(1,2)=-cchi3*schi1+cchi1*schi2*schi3
      rot(2,2)= cchi1*cchi3+schi1*schi2*schi3
      rot(3,2)=-cchi2*schi3
      rot(1,3)=-cchi1*cchi3*schi2-schi1*schi3
      rot(2,3)=-cchi3*schi1*schi2
      rot(3,3)= cchi2*cchi3
      return
      end function

      real*8 function tfrotgeo(geo,chi) result(geo1)
      implicit none
      dimension geo1(3,3)
      real*8, intent(in)::geo(3,3),chi(3)
      real*8 cschi1,snchi1,cschi2,snchi2,cschi3,snchi3,g1(3)
      cschi1=cos(chi(1))
      snchi1=sin(chi(1))
      cschi2=cos(chi(2))
      snchi2=sin(chi(2))
      cschi3=cos(chi(3))
      snchi3=sin(chi(3))
      g1       = geo(:,1)*cschi1+ geo(:,3)*snchi1
      geo1(:,3)=-geo(:,1)*snchi1+ geo(:,3)*cschi1
      geo1(:,2)= geo(:,2)*cschi2+geo1(:,3)*snchi2
      geo1(:,3)=-geo(:,2)*snchi2+geo1(:,3)*cschi2
      geo1(:,1)= g1      *cschi3-geo1(:,2)*snchi3
      geo1(:,2)= g1      *snchi3+geo1(:,2)*cschi3
      return
      end function

      real*8 function tfderotgeo(geo,chi) result(geo1)
      implicit none
      real*8, intent(in)::geo(3,3),chi(3)
      real*8 cschi1,snchi1,cschi2,snchi2,cschi3,snchi3,
     $     g1(3),g3(3)
      dimension geo1(3,3)
      cschi1=cos(chi(1))
      snchi1=sin(chi(1))
      cschi2=cos(chi(2))
      snchi2=sin(chi(2))
      cschi3=cos(chi(3))
      snchi3=sin(chi(3))
      g1       = geo(:,1) *cschi3+geo(:,2)*snchi3
      geo1(:,2)=-geo(:,1) *snchi3+geo(:,2)*cschi3
      g3       = geo1(:,2)*snchi2+geo(:,3)*cschi2
      geo1(:,2)= geo1(:,2)*cschi2-geo(:,3)*snchi2
      geo1(:,3)=        g3*cschi1+      g1*snchi1
      geo1(:,1)=       -g3*snchi1+      g1*cschi1
      return
      end function

      real*8 function tgrot(geo0,geo1) result(a)
      implicit none
      real*8 ,intent(in)::geo0(3,3),geo1(3,3)
      dimension a(3)
      real*8 a13,a21
      a(2)=asin(
     1     -geo0(1,2)*geo1(1,3)-geo0(2,2)*geo1(2,3)-geo0(3,2)*geo1(3,3))
      a13= geo0(1,1)*geo1(1,3)+geo0(2,1)*geo1(2,3)+geo0(3,1)*geo1(3,3)
      if(a13 .eq. 0.d0)then
        a(1)=0.d0
      else
        a(1)=-atan(a13,
     $       geo0(1,3)*geo1(1,3)+geo0(2,3)*geo1(2,3)
     $       +geo0(3,3)*geo1(3,3))
      endif
      a21= geo0(1,2)*geo1(1,1)+geo0(2,2)*geo1(2,1)+geo0(3,2)*geo1(3,1)
      if(a21 .eq. 0.d0)then
        a(3)=0.d0
      else
        a(3)=atan(-a21,
     $       geo0(1,2)*geo1(1,2)+geo0(2,2)*geo1(2,2)
     $       +geo0(3,2)*geo1(3,2))
      endif
      return
      end function

      real*8 function tfgeo1s(lxp) result(gv)
      use ffs_pointer
      implicit none
      integer*4 , intent(in)::lxp
      dimension gv(3,4)
      real*8 geo1(3,4),pos0,gam0
      geo1=geo(:,:,lxp+1)
      pos0=pos(lxp+1)
      gam0=gammab(lxp+1)
      call tfgeo1(lxp,lxp+1,.true.,.false.)
      gv=geo(:,:,lxp+1)
      geo(:,:,lxp+1)=geo1
      gammab(lxp+1)=gam0
      pos(lxp+1)=pos0
      return
      end function

      real*8 function  tforbitgeo(geo,cod) result(og)
      implicit none
      dimension og(3,4)
      real*8 , intent(in):: geo(3,4),cod(4)
      real*8 chi2i,cchi2i,schi2i,chi1i,cchi1i,schi1i,g1(3)
      chi2i =-asin(min(1.d0,max(-1.d0,cod(4))))
      cchi2i=cos(chi2i)
      schi2i=sin(chi2i)
      chi1i =-asin(min(1.d0,max(-1.d0,cod(2)/cchi2i)))
      cchi1i=cos(chi1i)
      schi1i=sin(chi1i)
      og(:,4)=geo(:,4)+geo(:,1)*cod(1)+geo(:,2)*cod(3)
      og(:,1)= cchi1i*geo(:,1)+schi1i*geo(:,3)
      g1     =-schi1i*geo(:,1)+cchi1i*geo(:,3)
      og(:,3)= cchi2i*g1-schi2i*geo(:,2)
      og(:,2)= schi2i*g1+cchi2i*geo(:,2)
      return
      end function

      real*8 function tfgeofrac(l,fr,irtc) result(gv)
      use ffs
      use ffs_pointer
      implicit none
      dimension gv(3,4)
      type (sad_descriptor) dsave(kwMAX)
      type (sad_comp) , pointer :: cmp
      integer*4 , intent(in)::l
      integer*4 nvar
      integer*4 ,intent(out):: irtc
      real*8 , intent(in)::fr
      logical*4 chg
      if(fr .eq. 0.d0)then
        gv=geo(:,:,l)
      else
        call qfracsave(l,dsave,nvar,.true.)
        call compelc(l,cmp)
        call qfracseg(cmp,cmp,0.d0,fr,chg,irtc)
        if(irtc .ne. 0)then
          call tffserrorhandle(l,irtc)
          gv=geo(:,:,l)
        elseif(chg)then
          gv=tfgeo1s(l)
          call qfracsave(l,dsave,nvar,.false.)
        else
          gv=geo(:,:,l)
        endif
      endif
      return
      end function

      end module


      SUBROUTINE MB02UD( FACT, SIDE, TRANS, JOBP, M, N, ALPHA, RCOND,
     $                   RANK, R, LDR, Q, LDQ, SV, B, LDB, RP, LDRP,
     $                   DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To compute the minimum norm least squares solution of one of the
C     following linear systems
C
C        op(R)*X = alpha*B,                                          (1)
C        X*op(R) = alpha*B,                                          (2)
C
C     where alpha is a real scalar, op(R) is either R or its transpose,
C     R', R is an L-by-L real upper triangular matrix, B is an M-by-N
C     real matrix, and L = M for (1), or L = N for (2). Singular value
C     decomposition, R = Q*S*P', is used, assuming that R is rank
C     deficient.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     FACT    CHARACTER*1
C             Specifies whether R has been previously factored or not,
C             as follows:
C             = 'F':  R has been factored and its rank and singular
C                     value decomposition, R = Q*S*P', are available;
C             = 'N':  R has not been factored and its singular value
C                     decomposition, R = Q*S*P', should be computed.
C
C     SIDE    CHARACTER*1
C             Specifies whether op(R) appears on the left or right
C             of X as follows:
C             = 'L':  Solve op(R)*X = alpha*B  (op(R) is on the left);
C             = 'R':  Solve X*op(R) = alpha*B  (op(R) is on the right).
C
C     TRANS   CHARACTER*1
C             Specifies the form of op(R) to be used as follows:
C             = 'N':  op(R) = R;
C             = 'T':  op(R) = R';
C             = 'C':  op(R) = R'.
C
C     JOBP    CHARACTER*1
C             Specifies whether or not the pseudoinverse of R is to be
C             computed or it is available as follows:
C             = 'P':  Compute pinv(R), if FACT = 'N', or
C                     use pinv(R),     if FACT = 'F';
C             = 'N':  Do not compute or use pinv(R).
C
C     Input/Output Parameters
C
C     M       (input) INTEGER
C             The number of rows of the matrix B.  M >= 0.
C
C     N       (input) INTEGER
C             The number of columns of the matrix B.  N >= 0.
C
C     ALPHA   (input) DOUBLE PRECISION
C             The scalar alpha. When alpha is zero then B need not be
C             set before entry.
C
C     RCOND   (input) DOUBLE PRECISION
C             RCOND is used to determine the effective rank of R.
C             Singular values of R satisfying Sv(i) <= RCOND*Sv(1) are
C             treated as zero. If RCOND <= 0, then EPS is used instead,
C             where EPS is the relative machine precision (see LAPACK
C             Library routine DLAMCH).  RCOND <= 1.
C             RCOND is not used if FACT = 'F'.
C
C     RANK    (input or output) INTEGER
C             The rank of matrix R.
C             RANK is an input parameter when FACT = 'F', and an output
C             parameter when FACT = 'N'.  L >= RANK >= 0.
C
C     R       (input/output) DOUBLE PRECISION array, dimension (LDR,L)
C             On entry, if FACT = 'F', the leading L-by-L part of this
C             array must contain the L-by-L orthogonal matrix P' from
C             singular value decomposition, R = Q*S*P', of the matrix R;
C             if JOBP = 'P', the first RANK rows of P' are assumed to be
C             scaled by inv(S(1:RANK,1:RANK)).
C             On entry, if FACT = 'N', the leading L-by-L upper
C             triangular part of this array must contain the upper
C             triangular matrix R.
C             On exit, if INFO = 0, the leading L-by-L part of this
C             array contains the L-by-L orthogonal matrix P', with its
C             first RANK rows scaled by inv(S(1:RANK,1:RANK)), when
C             JOBP = 'P'.
C
C     LDR     INTEGER
C             The leading dimension of array R.  LDR >= MAX(1,L).
C
C     Q       (input or output) DOUBLE PRECISION array, dimension
C             (LDQ,L)
C             On entry, if FACT = 'F', the leading L-by-L part of this
C             array must contain the L-by-L orthogonal matrix Q from
C             singular value decomposition, R = Q*S*P', of the matrix R.
C             If FACT = 'N', this array need not be set on entry, and
C             on exit, if INFO = 0, the leading L-by-L part of this
C             array contains the orthogonal matrix Q.
C
C     LDQ     INTEGER
C             The leading dimension of array Q.  LDQ >= MAX(1,L).
C
C     SV      (input or output) DOUBLE PRECISION array, dimension (L)
C             On entry, if FACT = 'F', the first RANK entries of this
C             array must contain the reciprocal of the largest RANK
C             singular values of the matrix R, and the last L-RANK
C             entries of this array must contain the remaining singular
C             values of R sorted in descending order.
C             If FACT = 'N', this array need not be set on input, and
C             on exit, if INFO = 0, the first RANK entries of this array
C             contain the reciprocal of the largest RANK singular values
C             of the matrix R, and the last L-RANK entries of this array
C             contain the remaining singular values of R sorted in
C             descending order.
C
C     B       (input/output) DOUBLE PRECISION array, dimension (LDB,N)
C             On entry, if ALPHA <> 0, the leading M-by-N part of this
C             array must contain the matrix B.
C             On exit, if INFO = 0 and RANK > 0, the leading M-by-N part
C             of this array contains the M-by-N solution matrix X.
C
C     LDB     INTEGER
C             The leading dimension of array B.  LDB >= MAX(1,M).
C
C     RP      (input or output) DOUBLE PRECISION array, dimension
C             (LDRP,L)
C             On entry, if FACT = 'F', JOBP = 'P', and RANK > 0, the
C             leading L-by-L part of this array must contain the L-by-L
C             matrix pinv(R), the Moore-Penrose pseudoinverse of R.
C             On exit, if FACT = 'N', JOBP = 'P', and RANK > 0, the
C             leading L-by-L part of this array contains the L-by-L
C             matrix pinv(R), the Moore-Penrose pseudoinverse of R.
C             If JOBP = 'N', this array is not referenced.
C
C     LDRP    INTEGER
C             The leading dimension of array RP.
C             LDRP >= MAX(1,L), if JOBP = 'P'.
C             LDRP >= 1,        if JOBP = 'N'.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal LDWORK;
C             if INFO = i, 1 <= i <= L, then DWORK(2:L) contain the
C             unconverged superdiagonal elements of an upper bidiagonal
C             matrix D whose diagonal is in SV (not necessarily sorted).
C             D satisfies R = Q*D*P', so it has the same singular
C             values as R, and singular vectors related by Q and P'.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= MAX(1,L),   if FACT = 'F';
C             LDWORK >= MAX(1,5*L), if FACT = 'N'.
C             For optimum performance LDWORK should be larger than
C             MAX(1,L,M*N),   if FACT = 'F';
C             MAX(1,5*L,M*N), if FACT = 'N'.
C
C             If LDWORK = -1, then a workspace query is assumed;
C             the routine only calculates the optimal size of the
C             DWORK array, returns this value as the first entry of
C             the DWORK array, and no error message related to LDWORK
C             is issued by XERBLA.
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             > 0:  if INFO = i, i = 1:L, the SVD algorithm has failed
C                   to converge. In this case INFO specifies how many
C                   superdiagonals did not converge (see the description
C                   of DWORK); this failure is not likely to occur.
C
C     METHOD
C
C     The L-by-L upper triangular matrix R is factored as  R = Q*S*P',
C     if FACT = 'N', using SLICOT Library routine MB03UD, where Q and P
C     are L-by-L orthogonal matrices and S is an L-by-L diagonal matrix
C     with non-negative diagonal elements, SV(1), SV(2), ..., SV(L),
C     ordered decreasingly. Then, the effective rank of R is estimated,
C     and matrix (or matrix-vector) products and scalings are used to
C     compute X. If FACT = 'F', only matrix (or matrix-vector) products
C     and scalings are performed.
C
C     FURTHER COMMENTS
C
C     Option JOBP = 'P' should be used only if the pseudoinverse is
C     really needed. Usually, it is possible to avoid the use of
C     pseudoinverse, by computing least squares solutions.
C     The routine uses BLAS 3 calculations if LDWORK >= M*N, and BLAS 2
C     calculations, otherwise. No advantage of any additional workspace
C     larger than L is taken for matrix products, but the routine can
C     be called repeatedly for chunks of columns of B, if LDWORK < M*N.
C
C     CONTRIBUTOR
C
C     V. Sima, Research Institute of Informatics, Bucharest, Oct. 1999.
C
C     REVISIONS
C
C     V. Sima, Feb. 2000, Aug. 2011.
C
C     KEYWORDS
C
C     Bidiagonalization, orthogonal transformation, singular value
C     decomposition, singular values, triangular form.
C
C    ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ONE, ZERO
      PARAMETER         ( ONE = 1.0D0, ZERO = 0.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         FACT, JOBP, SIDE, TRANS
      INTEGER           INFO, LDB, LDQ, LDR, LDRP, LDWORK, M, N, RANK
      DOUBLE PRECISION  ALPHA, RCOND
C     .. Array Arguments ..
      DOUBLE PRECISION  B(LDB,*), DWORK(*), Q(LDQ,*), R(LDR,*),
     $                  RP(LDRP,*), SV(*)
C     .. Local Scalars ..
      LOGICAL           LEFT, LQUERY, NFCT, PINV, TRAN
      CHARACTER*1       NTRAN
      INTEGER           I, L, MAXWRK, MINWRK, MN
      DOUBLE PRECISION  TOLL
C     .. External Functions ..
      LOGICAL           LSAME
      DOUBLE PRECISION  DLAMCH
      EXTERNAL          DLAMCH, LSAME
C     .. External Subroutines ..
      EXTERNAL          DCOPY, DGEMM, DGEMV, DLACPY, DLASET, MB01SD,
     $                  MB03UD, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         MAX, MIN
C     .. Executable Statements ..
C
C     Check the input scalar arguments.
C
      INFO = 0
      NFCT = LSAME( FACT,  'N' )
      LEFT = LSAME( SIDE,  'L' )
      PINV = LSAME( JOBP,  'P' )
      TRAN = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' )
      IF( LEFT ) THEN
         L = M
      ELSE
         L = N
      END IF
      MN = M*N
      IF( .NOT.NFCT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE,  'R' ) ) THEN
         INFO = -2
      ELSE IF( .NOT.TRAN .AND. .NOT.LSAME( TRANS, 'N' ) ) THEN
         INFO = -3
      ELSE IF( .NOT.PINV .AND. .NOT.LSAME( JOBP,  'N' ) ) THEN
         INFO = -4
      ELSE IF( M.LT.0 ) THEN
         INFO = -5
      ELSE IF( N.LT.0 ) THEN
         INFO = -6
      ELSE IF( NFCT .AND. RCOND.GT.ONE ) THEN
         INFO = -8
      ELSE IF( .NOT.NFCT .AND. ( RANK.LT.ZERO .OR. RANK.GT.L ) ) THEN
         INFO = -9
      ELSE IF( LDR.LT.MAX( 1, L ) ) THEN
         INFO = -11
      ELSE IF( LDQ.LT.MAX( 1, L ) ) THEN
         INFO = -13
      ELSE IF( LDB.LT.MAX( 1, M ) ) THEN
         INFO = -16
      ELSE IF( LDRP.LT.1 .OR. ( PINV .AND. LDRP.LT.L ) ) THEN
         INFO = -18
      ELSE
C
C        Compute workspace
C        (Note: Comments in the code beginning "Workspace:" describe the
C        minimal amount of workspace needed at that point in the code,
C        as well as the preferred amount for good performance.)
C
         LQUERY = LDWORK.EQ.-1
         MINWRK = MAX( 1, L )
         MAXWRK = MAX( MINWRK, MN )
         IF( NFCT ) THEN
            CALL MB03UD( 'Vectors', 'Vectors', L, R, LDR, Q, LDQ, SV,
     $                   DWORK, -1, INFO )
            MINWRK = MAX( 1, 5*L )
            MAXWRK = MAX( MAXWRK, INT( DWORK( 1 ) ), MINWRK )
         END IF
         IF( LDWORK.LT.MINWRK .AND. .NOT.LQUERY )
     $      INFO = -20
      END IF
C
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB02UD', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         DWORK(1) = MAXWRK
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( L.EQ.0 ) THEN
         IF( NFCT )
     $      RANK = 0
         DWORK(1) = ONE
         RETURN
      END IF
C
      IF( NFCT ) THEN
C
C        Compute the SVD of R, R = Q*S*P'.
C        Matrix Q is computed in the array Q, and P' overwrites R.
C        Workspace: need   5*L;
C                   prefer larger.
C
         CALL MB03UD( 'Vectors', 'Vectors', L, R, LDR, Q, LDQ, SV,
     $                DWORK, LDWORK, INFO )
         IF ( INFO.NE.0 )
     $      RETURN
C
C        Use the default tolerance, if required.
C
         TOLL = RCOND
         IF( TOLL.LE.ZERO )
     $      TOLL = DLAMCH( 'Precision' )
         TOLL = MAX( TOLL*SV(1), DLAMCH( 'Safe minimum' ) )
C
C        Estimate the rank of R.
C
         DO 10 I = 1, L
            IF ( TOLL.GT.SV(I) )
     $         GO TO 20
   10    CONTINUE
C
         I = L + 1
   20    CONTINUE
         RANK = I - 1
C
         DO 30 I = 1, RANK
            SV(I) = ONE / SV(I)
   30    CONTINUE
C
         IF( PINV .AND. RANK.GT.0 ) THEN
C
C           Compute  pinv(S)'*P'  in R.
C
            CALL MB01SD( 'Row scaling', RANK, L, R, LDR, SV, SV )
C
C           Compute  pinv(R) = P*pinv(S)*Q'  in  RP.
C
            CALL DGEMM( 'Transpose', 'Transpose', L, L, RANK, ONE, R,
     $                  LDR, Q, LDQ, ZERO, RP, LDRP )
         END IF
      END IF
C
C     Return if min(M,N) = 0 or RANK = 0.
C
      IF( MIN( M, N ).EQ.0 .OR. RANK.EQ.0 ) THEN
         DWORK(1) = MAXWRK
         RETURN
      END IF
C
C     Set X = 0 if alpha = 0.
C
      IF( ALPHA.EQ.ZERO ) THEN
         CALL DLASET( 'Full', M, N, ZERO, ZERO, B, LDB )
         DWORK(1) = MAXWRK
         RETURN
      END IF
C
      IF( PINV ) THEN
C
         IF( LEFT ) THEN
C
C           Compute  alpha*op(pinv(R))*B  in workspace and save it in B.
C           Workspace:  need   M   (BLAS 2);
C                       prefer M*N (BLAS 3).
C
            IF( LDWORK.GE.MN ) THEN
               CALL DGEMM( TRANS, 'NoTranspose', M, N, M, ALPHA,
     $                     RP, LDRP, B, LDB, ZERO, DWORK, M )
               CALL DLACPY( 'Full', M, N, DWORK, M, B, LDB )
            ELSE
C
               DO 40 I = 1, N
                  CALL DGEMV( TRANS, M, M, ALPHA, RP, LDRP, B(1,I), 1,
     $                        ZERO, DWORK, 1 )
                  CALL DCOPY( M, DWORK, 1, B(1,I), 1 )
   40          CONTINUE
C
            END IF
         ELSE
C
C           Compute  alpha*B*op(pinv(R))  in workspace and save it in B.
C           Workspace:  need   N   (BLAS 2);
C                       prefer M*N (BLAS 3).
C
            IF( LDWORK.GE.MN ) THEN
               CALL DGEMM( 'NoTranspose', TRANS, M, N, N, ALPHA, B, LDB,
     $                     RP, LDRP, ZERO, DWORK, M )
               CALL DLACPY( 'Full', M, N, DWORK, M, B, LDB )
            ELSE
C
               IF( TRAN ) THEN
                  NTRAN = 'N'
               ELSE
                  NTRAN = 'T'
               END IF
C
               DO 50 I = 1, M
                  CALL DGEMV( NTRAN, N, N, ALPHA, RP, LDRP, B(I,1), LDB,
     $                        ZERO, DWORK, 1 )
                  CALL DCOPY( N, DWORK, 1, B(I,1), LDB )
   50          CONTINUE
C
            END IF
         END IF
C
      ELSE
C
         IF( LEFT ) THEN
C
C           Compute  alpha*P*pinv(S)*Q'*B  or  alpha*Q*pinv(S)'*P'*B.
C           Workspace:  need   M   (BLAS 2);
C                       prefer M*N (BLAS 3).
C
            IF( LDWORK.GE.MN ) THEN
               IF( TRAN ) THEN
C
C                 Compute  alpha*P'*B  in workspace.
C
                  CALL DGEMM( 'NoTranspose', 'NoTranspose', M, N, M,
     $                        ALPHA, R, LDR, B, LDB, ZERO, DWORK, M )
C
C                 Compute  alpha*pinv(S)'*P'*B.
C
                  CALL MB01SD( 'Row scaling', RANK, N, DWORK, M, SV,
     $                         SV )
C
C                 Compute  alpha*Q*pinv(S)'*P'*B.
C
                  CALL DGEMM( 'NoTranspose', 'NoTranspose', M, N, RANK,
     $                        ONE, Q, LDQ, DWORK, M, ZERO, B, LDB )
               ELSE
C
C                 Compute  alpha*Q'*B  in workspace.
C
                  CALL DGEMM( 'Transpose', 'NoTranspose', M, N, M,
     $                        ALPHA, Q, LDQ, B, LDB, ZERO, DWORK, M )
C
C                 Compute  alpha*pinv(S)*Q'*B.
C
                  CALL MB01SD( 'Row scaling', RANK, N, DWORK, M, SV,
     $                         SV )
C
C                 Compute  alpha*P*pinv(S)*Q'*B.
C
                  CALL DGEMM( 'Transpose', 'NoTranspose', M, N, RANK,
     $                        ONE, R, LDR, DWORK, M, ZERO, B, LDB )
               END IF
            ELSE
               IF( TRAN ) THEN
C
C                 Compute  alpha*P'*B  in B using workspace.
C
                  DO 60 I = 1, N
                     CALL DGEMV( 'NoTranspose', M, M, ALPHA, R, LDR,
     $                           B(1,I), 1, ZERO, DWORK, 1 )
                     CALL DCOPY( M, DWORK, 1, B(1,I), 1 )
   60             CONTINUE
C
C                 Compute  alpha*pinv(S)'*P'*B.
C
                  CALL MB01SD( 'Row scaling', RANK, N, B, LDB, SV, SV )
C
C                 Compute  alpha*Q*pinv(S)'*P'*B  in B using workspace.
C
                  DO 70 I = 1, N
                     CALL DGEMV( 'NoTranspose', M, RANK, ONE, Q, LDQ,
     $                           B(1,I), 1, ZERO, DWORK, 1 )
                     CALL DCOPY( M, DWORK, 1, B(1,I), 1 )
   70             CONTINUE
               ELSE
C
C                 Compute  alpha*Q'*B  in B using workspace.
C
                  DO 80 I = 1, N
                     CALL DGEMV( 'Transpose', M, M, ALPHA, Q, LDQ,
     $                           B(1,I), 1, ZERO, DWORK, 1 )
                     CALL DCOPY( M, DWORK, 1, B(1,I), 1 )
   80             CONTINUE
C
C                 Compute  alpha*pinv(S)*Q'*B.
C
                  CALL MB01SD( 'Row scaling', RANK, N, B, LDB, SV, SV )
C
C                 Compute  alpha*P*pinv(S)*Q'*B  in B using workspace.
C
                  DO 90 I = 1, N
                     CALL DGEMV( 'Transpose', RANK, M, ONE, R, LDR,
     $                           B(1,I), 1, ZERO, DWORK, 1 )
                     CALL DCOPY( M, DWORK, 1, B(1,I), 1 )
   90             CONTINUE
               END IF
            END IF
         ELSE
C
C           Compute  alpha*B*P*pinv(S)*Q'  or  alpha*B*Q*pinv(S)'*P'.
C           Workspace:  need   N   (BLAS 2);
C                       prefer M*N (BLAS 3).
C
            IF( LDWORK.GE.MN ) THEN
               IF( TRAN ) THEN
C
C                 Compute  alpha*B*Q  in workspace.
C
                  CALL DGEMM( 'NoTranspose', 'NoTranspose', M, N, N,
     $                        ALPHA, B, LDB, Q, LDQ, ZERO, DWORK, M )
C
C                 Compute  alpha*B*Q*pinv(S)'.
C
                  CALL MB01SD( 'Column scaling', M, RANK, DWORK, M, SV,
     $                         SV )
C
C                 Compute  alpha*B*Q*pinv(S)'*P' in B.
C
                  CALL DGEMM( 'NoTranspose', 'NoTranspose', M, N, RANK,
     $                        ONE, DWORK, M, R, LDR, ZERO, B, LDB )
               ELSE
C
C                 Compute  alpha*B*P  in workspace.
C
                  CALL DGEMM( 'NoTranspose', 'Transpose', M, N, N,
     $                        ALPHA, B, LDB, R, LDR, ZERO, DWORK, M )
C
C                 Compute  alpha*B*P*pinv(S).
C
                  CALL MB01SD( 'Column scaling', M, RANK, DWORK, M, SV,
     $                         SV )
C
C                 Compute  alpha*B*P*pinv(S)*Q' in B.
C
                  CALL DGEMM( 'NoTranspose', 'Transpose', M, N, RANK,
     $                        ONE, DWORK, M, Q, LDQ, ZERO, B, LDB )
               END IF
            ELSE
               IF( TRAN ) THEN
C
C                 Compute  alpha*B*Q  in B using workspace.
C
                  DO 100 I = 1, M
                     CALL DGEMV( 'Transpose', N, N, ALPHA, Q, LDQ,
     $                           B(I,1), LDB, ZERO, DWORK, 1 )
                     CALL DCOPY( N, DWORK, 1, B(I,1), LDB )
  100             CONTINUE
C
C                 Compute  alpha*B*Q*pinv(S)'.
C
                  CALL MB01SD( 'Column scaling', M, RANK, B, LDB, SV,
     $                         SV )
C
C                 Compute  alpha*B*Q*pinv(S)'*P' in B using workspace.
C
                  DO 110 I = 1, M
                     CALL DGEMV( 'Transpose', RANK, N, ONE, R, LDR,
     $                           B(I,1), LDB, ZERO, DWORK, 1 )
                     CALL DCOPY( N, DWORK, 1, B(I,1), LDB )
  110             CONTINUE
C
               ELSE
C
C                 Compute  alpha*B*P  in B using workspace.
C
                  DO 120 I = 1, M
                     CALL DGEMV( 'NoTranspose', N, N, ALPHA, R, LDR,
     $                           B(I,1), LDB, ZERO, DWORK, 1 )
                     CALL DCOPY( N, DWORK, 1, B(I,1), LDB )
  120             CONTINUE
C
C                 Compute  alpha*B*P*pinv(S).
C
                  CALL MB01SD( 'Column scaling', M, RANK, B, LDB, SV,
     $                         SV )
C
C                 Compute  alpha*B*P*pinv(S)*Q' in B using workspace.
C
                  DO 130 I = 1, M
                     CALL DGEMV( 'NoTranspose', N, RANK, ONE, Q, LDQ,
     $                           B(I,1), LDB, ZERO, DWORK, 1 )
                     CALL DCOPY( N, DWORK, 1, B(I,1), LDB )
  130             CONTINUE
               END IF
            END IF
         END IF
      END IF
C
C     Return optimal workspace in DWORK(1).
C
      DWORK(1) = MAXWRK
C
      RETURN
C *** Last line of MB02UD ***
      END


	INCLUDE 'VICMAIN_FOR'
	SUBROUTINE MAIN44
C
C	This program accepts as input a TIMS image in temperature
C	units, and produces as output a simulation of an ASTER
C	image in radiance units.  It does this by matching each ASTER
C	channel to its closest TIMS channel, and assuming that there
C	is no emissivity change over the change of wavelengths.
C
C	4/11/97 ...rea... Modified to use the PFM calibration of the
C			  ASTER sensor
C
	REAL WAVE(6)/8.2873,
     &		     8.6349,
     &		     9.0793,
     &              99.9999,
     &		    10.6592,
     &		    11.2893/
	INTEGER*2 HBUF(10000)
C
C		Open data sets
C
	CALL XVUNIT(INUNIT,'INP',1,ISTAT,' ')
	CALL XVOPEN(INUNIT,ISTAT,'IO_ACT','SA','OPEN_ACT','SA',
     &		    'U_FORMAT','HALF',' ')
	CALL XVSIZE(ISL,ISS,NL,NS,NLIN,NSIN)
	CALL XVUNIT(IOUT,'OUT',1,ISTAT,' ')
	CALL XVOPEN(IOUT,ISTAT,'IO_ACT','SA','OPEN_ACT','SA',
     &		'U_NL',NL,'U_NS',NS,'U_ORG','BIL','OP','WRITE',
     &		'U_FORMAT','HALF','O_FORMAT','HALF','U_NB',5,' ')
C
	IEL = ISL+NL-1
	IES = ISS+NS-1
C
	IF(IEL.GT.NLIN .OR. IES.GT.NSIN) THEN
	    CALL XVMESSAGE(
     &         ' Size field specified overruns file dimensions',' ')
	    CALL ABEND
	ENDIF
C
	CALL XLADD(IOUT,'HISTORY','LBL1',
     &		'Radiance Image to Simulate ASTER TIR',ISTAT,
     &		'FORMAT','STRING',' ')
	CALL XLADD(IOUT,'HISTORY','LBL2',
     &		   'DN = milliwatts/m*m*sr*micrometer',
     &		   ISTAT,'FORMAT','STRING',' ')
C
	DO ILINE=ISL,IEL
C
	    DO ICHAN=1,6
C							read & write a line
		CALL XVREAD(INUNIT,HBUF,ISTAT,'LINE',ILINE,'SAMP',ISS,
     &			    'BAND',ICHAN,'NSAMPS',NS,' ')
		IF (ICHAN .NE. 4) THEN
		    DO ISAMP=1,NS
			X = (FLOAT(HBUF(ISAMP)) / 100.0) + 273.15
			Y = 1000.0 * PLANCK(WAVE(ICHAN),X)
			HBUF(ISAMP) = NINT(Y)
		    END DO
		    CALL XVWRIT(IOUT,HBUF,ISTAT,' ')
		END IF
	    END DO
	END DO
C							Close all datasets
C
	CALL XVCLOSE(INUNIT,ISTAT,' ')
	CALL XVCLOSE(IOUT,ISTAT,' ')
C
	RETURN
	END