************************************************************************
* SUBROUTINE PNETU              ALL SYSTEMS                   97/01/22
* PURPOSE :
* EASY TO USE SUBROUTINE FOR LARGE-SCALE UNCONSTRAINED MINIMIZATION.
*
* PARAMETERS :
*  II  NF  NUMBER OF VARIABLES.
*  RI  X(NF)  VECTOR OF VARIABLES.
*  II  IPAR(7)  INTEGER PAREMETERS:
*      IPAR(1)  MAXIMUM NUMBER OF ITERATIONS.
*      IPAR(2)  MAXIMUM NUMBER OF FUNCTION EVALUATIONS.
*      IPAR(3)  MAXIMUM NUMBER OF GRADIENT EVALUATIONS.
*      IPAR(4)  ESTIMATION INDICATOR. IPAR(4)=0-MINIMUM IS NOT
*         ESTIMATED. IPAR(4)=1-MINIMUM IS ESTIMATED BY THE VALUE
*         RPAR(6).
*      IPAR(5)  CHOICE OF DIRECTION VECTORS AFTER RESTARTS.
*         IPAR(5)=1-THE NEWTON DIRECTIONS ARE USED. IPAR(5)=2-THE
*         STEEPEST DESCENT DIRECTIONS ARE USED.
*      IPAR(6)  CHOICE OF PRECONDITIONING STRATEGY.
*         IPAR(6)=1-PRECONDITIONING IS NOT USED.
*         IPAR(6)=2-PRECONDITIONING BY THE LIMITED MEMORY BFGS METHOD
*         IS USED.
*      IPAR(7)  THE NUMBER OF LIMITED-MEMORY VARIABLE METRIC UPDATES
*         IN EACH ITERATION (THEY USE 2*MF STORED VECTORS).
*  RI  RPAR(9)  REAL PARAMETERS:
*      RPAR(1)  MAXIMUM STEPSIZE.
*      RPAR(2)  TOLERANCE FOR THE CHANGE OF VARIABLES.
*      RPAR(3)  TOLERANCE FOR THE CHANGE OF FUNCTION VALUES.
*      RPAR(4)  TOLERANCE FOR THE FUNCTION FALUE.
*      RPAR(5)  TOLERANCE FOR THE GRADIENT NORM.
*      RPAR(6)  ESTIMATION OF THE MINIMUM FUNCTION VALUE.
*      RPAR(7)  THIS PARAMETER IS NOT USED IN THE SUBROUTINE PNET.
*      RPAR(8)  THIS PARAMETER IS NOT USED IN THE SUBROUTINE PNET.
*      RPAR(9)  THIS PARAMETER IS NOT USED IN THE SUBROUTINE PNET.
*  RO  F  VALUE OF THE OBJECTIVE FUNCTION.
*  RO  GMAX  MAXIMUM PARTIAL DERIVATIVE.
*  II  IPRNT  PRINT SPECIFICATION. IPRNT=0-NO PRINT.
*         ABS(IPRNT)=1-PRINT OF FINAL RESULTS.
*         ABS(IPRNT)=2-PRINT OF FINAL RESULTS AND ITERATIONS.
*         IPRNT>0-BASIC FINAL RESULTS. IPRNT<0-EXTENDED FINAL
*         RESULTS.
*  IO  ITERM  VARIABLE THAT INDICATES THE CAUSE OF TERMINATION.
*         ITERM=1-IF ABS(X-XO) WAS LESS THAN OR EQUAL TO TOLX IN
*                   MTESX (USUALLY TWO) SUBSEQUENT ITERATIONS.
*         ITERM=2-IF ABS(F-FO) WAS LESS THAN OR EQUAL TO TOLF IN
*                   MTESF (USUALLY TWO) SUBSEQUENT ITERATIONS.
*         ITERM=3-IF F IS LESS THAN OR EQUAL TO TOLB.
*         ITERM=4-IF GMAX IS LESS THAN OR EQUAL TO TOLG.
*         ITERM=6-IF THE TERMINATION CRITERION WAS NOT SATISFIED,
*                   BUT THE SOLUTION OBTAINED IS PROBABLY ACCEPTABLE.
*         ITERM=11-IF NIT EXCEEDED MIT. ITERM=12-IF NFV EXCEEDED MFV.
*         ITERM=13-IF NFG EXCEEDED MFG. ITERM<0-IF THE METHOD FAILED.
*
* VARIABLES IN COMMON /STAT/ (STATISTICS) :
*  IO  NRES  NUMBER OF RESTARTS.
*  IO  NDEC  NUMBER OF MATRIX DECOMPOSITIONS.
*  IO  NIN  NUMBER OF INNER ITERATIONS.
*  IO  NIT  NUMBER OF ITERATIONS.
*  IO  NFV  NUMBER OF FUNCTION EVALUATIONS.
*  IO  NFG  NUMBER OF GRADIENT EVALUATIONS.
*  IO  NFH  NUMBER OF HESSIAN EVALUATIONS.
*
* SUBPROGRAMS USED :
*  S   PNET  LIMITED MEMORY VARIABLE METRIC METHOD BASED ON THE STRANG
*         RECURRENCES.
*
* EXTERNAL SUBROUTINES :
*  SE  OBJ  COMPUTATION OF THE VALUE OF THE OBJECTIVE FUNCTION.
*         CALLING SEQUENCE: CALL OBJ(NF,X,FF) WHERE NF IS THE NUMBER
*         OF VARIABLES, X(NF) IS THE VECTOR OF VARIABLES AND FF IS
*         THE VALUE OF THE OBJECTIVE FUNCTION.
*  SE  DOBJ  COMPUTATION OF THE GRADIENT OF THE OBJECTIVE FUNCTION.
*         CALLING SEQUENCE: CALL DOBJ(NF,X,GF) WHERE NF IS THE NUMBER
*         OF VARIABLES, X(NF) IS THE VECTOR OF VARIABLES AND GF(NF)
*         IS THE GRADIENT OF THE OBJECTIVE FUNCTION.
*
      SUBROUTINE PNETU(NF,X,IPAR,RPAR,F,GMAX,IPRNT,ITERM)
      INTEGER NF,IPAR(7),IPRNT,ITERM
      DOUBLE PRECISION X(*),RPAR(9),F,GMAX
      INTEGER MF,NB,LGF,LGN,LS,LXO,LGO,LXS,LGS,LXM,LGM,LU1,LU2
      INTEGER NRES,NDEC,NIN,NIT,NFV,NFG,NFH
      COMMON /STAT/ NRES,NDEC,NIN,NIT,NFV,NFG,NFH
      DOUBLE PRECISION RA(:)
      ALLOCATABLE RA
      MF=IPAR(7)
      IF (MF.LE.0) MF=10
      ALLOCATE (RA(8*NF+2*NF*MF+2*MF))
      NB=0
*
*     POINTERS FOR AUXILIARY ARRAYS
*
      LGF=1
      LGN=LGF+NF
      LS=LGN+NF
      LXO=LS+NF
      LGO=LXO+NF
      LXS=LGO+NF
      LGS=LXS+NF
      LXM=LGS+NF
      LGM=LXM+NF*MF
      LU1=LGM+NF*MF
      LU2=LU1+MF
      CALL PNET(NF,NB,X,IPAR,RA,RA,RA(LGF),RA(LGN),RA(LS),RA(LXO),
     & RA(LGO),RA(LXS),RA(LGS),RA(LXM),RA(LGM),RA(LU1),RA(LU2),RPAR(1),
     & RPAR(2),RPAR(3),RPAR(4),RPAR(5),RPAR(6),GMAX,F,IPAR(1),IPAR(2),
     & IPAR(3),IPAR(4),IPAR(5),IPAR(6),MF,IPRNT,ITERM)
      DEALLOCATE (RA)
      RETURN
      END
************************************************************************
* SUBROUTINE PNETS              ALL SYSTEMS                   97/01/22
* PURPOSE :
* EASY TO USE SUBROUTINE FOR LARGE-SCALE BOX CONSTRAINED MINIMIZATION.
*
* PARAMETERS :
*  II  NF  NUMBER OF VARIABLES.
*  RI  X(NF)  VECTOR OF VARIABLES.
*  II  IX(NF)  VECTOR CONTAINING TYPES OF BOUNDS. IX(I)=0-VARIABLE
*         X(I) IS UNBOUNDED. IX(I)=1-LOWER BOUND XL(I).LE.X(I).
*         IX(I)=2-UPPER BOUND X(I).LE.XU(I). IX(I)=3-TWO SIDE BOUND
*         XL(I).LE.X(I).LE.XU(I). IX(I)=5-VARIABLE X(I) IS FIXED.
*  RI  XL(NF)  VECTOR CONTAINING LOWER BOUNDS FOR VARIABLES.
*  RI  XU(NF)  VECTOR CONTAINING UPPER BOUNDS FOR VARIABLES.
*  II  IPAR(7)  INTEGER PAREMETERS:
*      IPAR(1)  MAXIMUM NUMBER OF ITERATIONS.
*      IPAR(2)  MAXIMUM NUMBER OF FUNCTION EVALUATIONS.
*      IPAR(3)  MAXIMUM NUMBER OF GRADIENT EVALUATIONS.
*      IPAR(4)  ESTIMATION INDICATOR. IPAR(4)=0-MINIMUM IS NOT
*         ESTIMATED. IPAR(4)=1-MINIMUM IS ESTIMATED BY THE VALUE
*         RPAR(6).
*      IPAR(5)  CHOICE OF DIRECTION VECTORS AFTER RESTARTS.
*         IPAR(5)=1-THE NEWTON DIRECTIONS ARE USED. IPAR(5)=2-THE
*         STEEPEST DESCENT DIRECTIONS ARE USED.
*      IPAR(6)  CHOICE OF PRECONDITIONING STRATEGY.
*         IPAR(6)=1-PRECONDITIONING IS NOT USED.
*         IPAR(6)=2-PRECONDITIONING BY THE LIMITED MEMORY BFGS METHOD
*         IS USED.
*      IPAR(7)  THE NUMBER OF LIMITED-MEMORY VARIABLE METRIC UPDATES
*         IN EACH ITERATION (THEY USE 2*MF STORED VECTORS).
*  RI  RPAR(9)  REAL PARAMETERS:
*      RPAR(1)  MAXIMUM STEPSIZE.
*      RPAR(2)  TOLERANCE FOR THE CHANGE OF VARIABLES.
*      RPAR(3)  TOLERANCE FOR THE CHANGE OF FUNCTION VALUES.
*      RPAR(4)  TOLERANCE FOR THE FUNCTION FALUE.
*      RPAR(5)  TOLERANCE FOR THE GRADIENT NORM.
*      RPAR(6)  ESTIMATION OF THE MINIMUM FUNCTION VALUE.
*      RPAR(7)  THIS PARAMETER IS NOT USED IN THE SUBROUTINE PNET.
*      RPAR(8)  THIS PARAMETER IS NOT USED IN THE SUBROUTINE PNET.
*      RPAR(9)  THIS PARAMETER IS NOT USED IN THE SUBROUTINE PNET.
*  RO  F  VALUE OF THE OBJECTIVE FUNCTION.
*  RO  GMAX  MAXIMUM PARTIAL DERIVATIVE.
*  II  IPRNT  PRINT SPECIFICATION. IPRNT=0-NO PRINT.
*         ABS(IPRNT)=1-PRINT OF FINAL RESULTS.
*         ABS(IPRNT)=2-PRINT OF FINAL RESULTS AND ITERATIONS.
*         IPRNT>0-BASIC FINAL RESULTS. IPRNT<0-EXTENDED FINAL
*         RESULTS.
*  IO  ITERM  VARIABLE THAT INDICATES THE CAUSE OF TERMINATION.
*         ITERM=1-IF ABS(X-XO) WAS LESS THAN OR EQUAL TO TOLX IN
*                   MTESX (USUALLY TWO) SUBSEQUENT ITERATIONS.
*         ITERM=2-IF ABS(F-FO) WAS LESS THAN OR EQUAL TO TOLF IN
*                   MTESF (USUALLY TWO) SUBSEQUENT ITERATIONS.
*         ITERM=3-IF F IS LESS THAN OR EQUAL TO TOLB.
*         ITERM=4-IF GMAX IS LESS THAN OR EQUAL TO TOLG.
*         ITERM=6-IF THE TERMINATION CRITERION WAS NOT SATISFIED,
*                   BUT THE SOLUTION OBTAINED IS PROBABLY ACCEPTABLE.
*         ITERM=11-IF NIT EXCEEDED MIT. ITERM=12-IF NFV EXCEEDED MFV.
*         ITERM=13-IF NFG EXCEEDED MFG. ITERM<0-IF THE METHOD FAILED.
*
* VARIABLES IN COMMON /STAT/ (STATISTICS) :
*  IO  NRES  NUMBER OF RESTARTS.
*  IO  NDEC  NUMBER OF MATRIX DECOMPOSITIONS.
*  IO  NIN  NUMBER OF INNER ITERATIONS.
*  IO  NIT  NUMBER OF ITERATIONS.
*  IO  NFV  NUMBER OF FUNCTION EVALUATIONS.
*  IO  NFG  NUMBER OF GRADIENT EVALUATIONS.
*  IO  NFH  NUMBER OF HESSIAN EVALUATIONS.
*
* SUBPROGRAMS USED :
*  S   PNET  LIMITED MEMORY VARIABLE METRIC METHOD BASED ON THE STRANG
*         RECURRENCES.
*
* EXTERNAL SUBROUTINES :
*  SE  OBJ  COMPUTATION OF THE VALUE OF THE OBJECTIVE FUNCTION.
*         CALLING SEQUENCE: CALL OBJ(NF,X,FF) WHERE NF IS THE NUMBER
*         OF VARIABLES, X(NF) IS THE VECTOR OF VARIABLES AND FF IS
*         THE VALUE OF THE OBJECTIVE FUNCTION.
*  SE  DOBJ  COMPUTATION OF THE GRADIENT OF THE OBJECTIVE FUNCTION.
*         CALLING SEQUENCE: CALL DOBJ(NF,X,GF) WHERE NF IS THE NUMBER
*         OF VARIABLES, X(NF) IS THE VECTOR OF VARIABLES AND GF(NF)
*         IS THE GRADIENT OF THE OBJECTIVE FUNCTION.
*
      SUBROUTINE PNETS(NF,X,IX,XL,XU,IPAR,RPAR,F,GMAX,IPRNT,ITERM)
      INTEGER NF,IX(*),IPAR(7),IPRNT,ITERM
      DOUBLE PRECISION X(*),XL(*),XU(*),RPAR(9),F,GMAX
      INTEGER MF,NB,LGF,LGN,LS,LXO,LGO,LXS,LGS,LXM,LGM,LU1,LU2
      INTEGER NRES,NDEC,NIN,NIT,NFV,NFG,NFH
      COMMON /STAT/ NRES,NDEC,NIN,NIT,NFV,NFG,NFH
      DOUBLE PRECISION RA(:)
      ALLOCATABLE RA
      MF=IPAR(7)
      IF (MF.LE.0) MF=10
      ALLOCATE (RA(8*NF+2*NF*MF+2*MF))
      NB=1
*
*     POINTERS FOR AUXILIARY ARRAYS
*
      LGF=1
      LGN=LGF+NF
      LS=LGN+NF
      LXO=LS+NF
      LGO=LXO+NF
      LXS=LGO+NF
      LGS=LXS+NF
      LXM=LGS+NF
      LGM=LXM+NF*MF
      LU1=LGM+NF*MF
      LU2=LU1+MF
      CALL PNET(NF,NB,X,IX,XL,XU,RA(LGF),RA(LGN),RA(LS),RA(LXO),
     & RA(LGO),RA(LXS),RA(LGS),RA(LXM),RA(LGM),RA(LU1),RA(LU2),RPAR(1),
     & RPAR(2),RPAR(3),RPAR(4),RPAR(5),RPAR(6),GMAX,F,IPAR(1),IPAR(2),
     & IPAR(3),IPAR(4),IPAR(5),IPAR(6),MF,IPRNT,ITERM)
      DEALLOCATE (RA)
      RETURN
      END
************************************************************************
* SUBROUTINE PNET               ALL SYSTEMS                   01/09/22
* PURPOSE :
* GENERAL SUBROUTINE FOR LARGE-SCALE BOX CONSTRAINED MINIMIZATION THAT
* USE THE LIMITED MEMORY VARIABLE METRIC METHOD BASED ON THE STRANG
* RECURRENCES.
*
* PARAMETERS :
*  II  NF  NUMBER OF VARIABLES.
*  II  NB  CHOICE OF SIMPLE BOUNDS. NB=0-SIMPLE BOUNDS SUPPRESSED.
*         NB>0-SIMPLE BOUNDS ACCEPTED.
*  RI  X(NF)  VECTOR OF VARIABLES.
*  II  IX(NF)  VECTOR CONTAINING TYPES OF BOUNDS. IX(I)=0-VARIABLE
*         X(I) IS UNBOUNDED. IX(I)=1-LOVER BOUND XL(I).LE.X(I).
*         IX(I)=2-UPPER BOUND X(I).LE.XU(I). IX(I)=3-TWO SIDE BOUND
*         XL(I).LE.X(I).LE.XU(I). IX(I)=5-VARIABLE X(I) IS FIXED.
*  RI  XL(NF)  VECTOR CONTAINING LOWER BOUNDS FOR VARIABLES.
*  RI  XU(NF)  VECTOR CONTAINING UPPER BOUNDS FOR VARIABLES.
*  RO  GF(NF)  GRADIENT OF THE OBJECTIVE FUNCTION.
*  RA  GN(NF)  OLD GRADIENT OF THE OBJECTIVE FUNCTION.
*  RO  S(NF)  DIRECTION VECTOR.
*  RA  XO(NF)  ARRAY CONTAINING INCREMENTS OF VARIABLES.
*  RA  GO(NF)  ARRAY CONTAINING INCREMENTS OF GRADIENTS.
*  RA  XS(NF)  AUXILIARY VECTOR.
*  RA  GS(NF)  AUXILIARY VECTOR.
*  RA  XM(NF*MF)  ARRAY CONTAINING INCREMENTS OF VARIABLES.
*  RA  GM(NF*MF)  ARRAY CONTAINING INCREMENTS OF GRADIENTS.
*  RA  U1(MF)  AUXILIARY VECTOR.
*  RA  U2(MF)  AUXILIARY VECTOR.
*  RI  XMAX  MAXIMUM STEPSIZE.
*  RI  TOLX  TOLERANCE FOR CHANGE OF VARIABLES.
*  RI  TOLF  TOLERANCE FOR CHANGE OF FUNCTION VALUES.
*  RI  TOLB  TOLERANCE FOR THE FUNCTION VALUE.
*  RI  TOLG  TOLERANCE FOR THE GRADIENT NORM.
*  RI  FMIN  ESTIMATION OF THE MINIMUM FUNCTION VALUE.
*  RO  GMAX  MAXIMUM PARTIAL DERIVATIVE.
*  RO  F  VALUE OF THE OBJECTIVE FUNCTION.
*  II  MIT  MAXIMUM NUMBER OF ITERATIONS.
*  II  MFV  MAXIMUM NUMBER OF FUNCTION EVALUATIONS.
*  II  MFG  MAXIMUM NUMBER OF GRADIENT EVALUATIONS.
*  II  IEST  ESTIMATION INDICATOR. IEST=0-MINIMUM IS NOT ESTIMATED.
*         IEST=1-MINIMUM IS ESTIMATED BY THE VALUE FMIN.
*  II  MOS1  CHOICE OF RESTARTS AFTER A CONSTRAINT CHANGE.
*         MOS1=1-RESTARTS ARE SUPPRESSED. MOS1=2-RESTARTS WITH
*         STEEPEST DESCENT DIRECTIONS ARE USED.
*  II  MOS1  CHOICE OF DIRECTION VECTORS AFTER RESTARTS. MOS1=1-THE
*         NEWTON DIRECTIONS ARE USED. MOS1=2-THE STEEPEST DESCENT
*         DIRECTIONS ARE USED.
*  II  MOS2  CHOICE OF PRECONDITIONING STRATEGY. MOS2=1-PRECONDITIONING
*         IS NOT USED. MOS2=2-PRECONDITIONING BY THE LIMITED MEMORY
*         BFGS METHOD IS USED.
*  II  MF  THE NUMBER OF LIMITED-MEMORY VARIABLE METRIC UPDATES
*         IN EACH ITERATION (THEY USE 2*MF STORED VECTORS).
*  II  IPRNT  PRINT SPECIFICATION. IPRNT=0-NO PRINT.
*         ABS(IPRNT)=1-PRINT OF FINAL RESULTS.
*         ABS(IPRNT)=2-PRINT OF FINAL RESULTS AND ITERATIONS.
*         IPRNT>0-BASIC FINAL RESULTS. IPRNT<0-EXTENDED FINAL
*         RESULTS.
*  IO  ITERM  VARIABLE THAT INDICATES THE CAUSE OF TERMINATION.
*         ITERM=1-IF ABS(X-XO) WAS LESS THAN OR EQUAL TO TOLX IN
*                   MTESX (USUALLY TWO) SUBSEQUEBT ITERATIONS.
*         ITERM=2-IF ABS(F-FO) WAS LESS THAN OR EQUAL TO TOLF IN
*                   MTESF (USUALLY TWO) SUBSEQUEBT ITERATIONS.
*         ITERM=3-IF F IS LESS THAN OR EQUAL TO TOLB.
*         ITERM=4-IF GMAX IS LESS THAN OR EQUAL TO TOLG.
*         ITERM=6-IF THE TERMINATION CRITERION WAS NOT SATISFIED,
*                   BUT THE SOLUTION OBTAINED IS PROBABLY ACCEPTABLE.
*         ITERM=11-IF NIT EXCEEDED MIT. ITERM=12-IF NFV EXCEEDED MFV.
*         ITERM=13-IF NFG EXCEEDED MFG. ITERM<0-IF THE METHOD FAILED.
*
* VARIABLES IN COMMON /STAT/ (STATISTICS) :
*  IO  NRES  NUMBER OF RESTARTS.
*  IO  NDEC  NUMBER OF MATRIX DECOMPOSITION.
*  IO  NIN  NUMBER OF INNER ITERATIONS.
*  IO  NIT  NUMBER OF ITERATIONS.
*  IO  NFV  NUMBER OF FUNCTION EVALUATIONS.
*  IO  NFG  NUMBER OF GRADIENT EVALUATIONS.
*  IO  NFH  NUMBER OF HESSIAN EVALUATIONS.
*
* SUBPROGRAMS USED :
*  S   PCBS04  ELIMINATION OF BOX CONSTRAINT VIOLATIONS.
*  S   PS1L01  STEPSIZE SELECTION USING LINE SEARCH.
*  S   PYADC0  ADDITION OF A BOX CONSTRAINT.
*  S   PYFUT1  TEST ON TERMINATION.
*  S   PYRMC0  DELETION OF A BOX CONSTRAINT.
*  S   PYTRCD  COMPUTATION OF PROJECTED DIFFERENCES FOR THE VARIABLE METRIC
*         UPDATE.
*  S   PYTRCG  COMPUTATION OF THE PROJECTED GRADIENT.
*  S   PYTRCS  COMPUTATION OF THE PROJECTED DIRECTION VECTOR.
*  S   MXDRCB BACKWARD PART OF THE STRANG FORMULA FOR PREMULTIPLICATION
*         OF THE VECTOR X BY AN IMPLICIT BFGS UPDATE.
*  S   MXDRCF FORWARD PART OF THE STRANG FORMULA FOR PREMULTIPLICATION
*         OF THE VECTOR X BY AN IMPLICIT BFGS UPDATE.
*  S   MXDRSU SHIFT OF COLUMNS OF THE RECTANGULAR MATRICES A AND B.
*         SHIFT OF ELEMENTS OF THE VECTOR U. THESE SHIFTS ARE USED IN
*         THE LIMITED MEMORY BFGS METHOD.
*  S   MXUDIR  VECTOR AUGMENTED BY THE SCALED VECTOR.
*  RF  MXUDOT  DOT PRODUCT OF TWO VECTORS.
*  S   MXVNEG  COPYING OF A VECTOR WITH CHANGE OF THE SIGN.
*  S   MXVCOP  COPYING OF A VECTOR.
*  S   MXVSCL  SCALING OF A VECTOR.
*  S   MXVSET  INITIATINON OF A VECTOR.
*  S   MXVDIF  DIFFERENCE OF TWO VECTORS.
*
* EXTERNAL SUBROUTINES :
*  SE  OBJ  COMPUTATION OF THE VALUE OF THE OBJECTIVE FUNCTION.
*         CALLING SEQUENCE: CALL OBJ(NF,X,FF) WHERE NF IS THE NUMBER
*         OF VARIABLES, X(NF) IS THE VECTOR OF VARIABLES AND FF IS
*         THE VALUE OF THE OBJECTIVE FUNCTION.
*  SE  DOBJ  COMPUTATION OF THE GRADIENT OF THE OBJECTIVE FUNCTION.
*         CALLING SEQUENCE: CALL DOBJ(NF,X,GF) WHERE NF IS THE NUMBER
*         OF VARIABLES, X(NF) IS THE VECTOR OF VARIABLES AND GF(NF)
*         IS THE GRADIENT OF THE OBJECTIVE FUNCTION.
*
* METHOD :
* LIMITED MEMORY VARIABLE METRIC METHOD BASED ON THE STRANG
* RECURRENCES.
*
      SUBROUTINE PNET(NF,NB,X,IX,XL,XU,GF,GN,S,XO,GO,XS,GS,XM,GM,U1,U2,
     & XMAX,TOLX,TOLF,TOLB,TOLG,FMIN,GMAX,F,MIT,MFV,MFG,IEST,MOS1,MOS2,
     & MF,IPRNT,ITERM)
      INTEGER NF,NB,IX(*),MIT,MFV,MFG,IEST,MOS1,MOS2,MF,IPRNT,ITERM
      DOUBLE PRECISION X(*),XL(*),XU(*),GF(*),GN(*),S(*),XO(*),GO(*),
     & XS(*),GS(*),XM(*),GM(*),U1(*),U2(*),XMAX,TOLX,TOLF,TOLG,TOLB,
     & FMIN,GMAX,F
      INTEGER ITERD,ITERS,KD,LD,NTESX,NTESF,MTESX,MTESF,MRED,KIT,
     & IREST,KBF,MES,MES1,MES2,MES3,MAXST,ISYS,ITES,INITS,KTERS,
     & IRES1,IRES2,INEW,IOLD,I,N,NRED,MX,MMX
      DOUBLE PRECISION R,RO,RP,FO,FP,P,PO,PP,GNORM,SNORM,RMIN,RMAX,
     & UMAX,FMAX,DMAX,ETA0,ETA9,EPS8,EPS9,ALF,ALF1,ALF2,RHO,RHO1,RHO2,
     & PAR,PAR1,PAR2,A,B,TOLD,TOLS,TOLP,EPS
      DOUBLE PRECISION MXUDOT
      INTEGER NRES,NDEC,NIN,NIT,NFV,NFG,NFH
      COMMON /STAT/ NRES,NDEC,NIN,NIT,NFV,NFG,NFH
      IF (ABS(IPRNT).GT.1) WRITE(6,'(1X,''ENTRY TO PNET :'')')
*
*     INITIATION
*
      KBF=0
      IF (NB.GT.0) KBF=2
      NRES=0
      NDEC=0
      NIN=0
      NIT=0
      NFV=0
      NFG=0
      NFH=0
      ISYS=0
      ITES=1
      MTESX=2
      MTESF=2
      INITS=2
      ITERM=0
      ITERD=0
      ITERS=2
      KTERS=3
      IREST=0
      IRES1=999
      IRES2=0
      MRED=10
      MES=4
      MES1=2
      MES2=2
      MES3=2
      EPS=0.80D 0
      ETA0=1.0D-15
      ETA9=1.0D 120
      EPS8=1.0D 0
      EPS9=1.0D-8
      ALF1=1.0D-10
      ALF2=1.0D 10
      RMAX=ETA9
      DMAX=ETA9
      FMAX=1.0D 20
      IF (IEST.LE.0) FMIN=-1.0D 60
      IF (IEST.GT.0) IEST=1
      IF (XMAX.LE.0.0D 0) XMAX=1.0D 16
      IF (TOLX.LE.0.0D 0) TOLX=1.0D-16
      IF (TOLF.LE.0.0D 0) TOLF=1.0D-14
      IF (TOLG.LE.0.0D 0) TOLG=1.0D-6
      IF (TOLB.LE.0.0D 0) TOLB=FMIN+1.0D-16
      TOLD=1.0D-4
      TOLS=1.0D-4
      TOLP=0.9D 0
      IF (MIT.LE.0) MIT=5000
      IF (MFV.LE.0) MFV=5000
      IF (MFG.LE.0) MFG=30000
      IF (MOS1.LE.0) MOS1=1
      IF (MOS2.LE.0) MOS2=1
      KD= 1
      LD=-1
      KIT=-(IRES1*NF+IRES2)
      FO=FMIN
*
*     INITIAL OPERATIONS WITH SIMPLE BOUNDS
*
      IF (KBF.GT.0) THEN
      DO 2 I = 1,NF
      IF ((IX(I).EQ.3.OR.IX(I).EQ.4) .AND. XU(I).LE.XL(I)) THEN
      XU(I) = XL(I)
      IX(I) = 5
      ELSE IF (IX(I).EQ.5 .OR. IX(I).EQ.6) THEN
      XL(I) = X(I)
      XU(I) = X(I)
      IX(I) = 5
      END IF
    2 CONTINUE
      CALL PCBS04(NF,X,IX,XL,XU,EPS9,KBF)
      CALL PYADC0(NF,N,X,IX,XL,XU,INEW)
      END IF
      CALL OBJ(NF,X,F)
      NFV=NFV+1
      CALL DOBJ(NF,X,GF)
      NFG=NFG+1
      LD=KD
11020 CONTINUE
      CALL PYTRCG(NF,NF,IX,GF,UMAX,GMAX,KBF,IOLD)
      CALL MXVCOP(NF,GF,GN)
      IF (ABS(IPRNT).GT.1)
     & WRITE (6,'(1X,''NIT='',I5,2X,''NFV='',I5,2X,''NFG='',I5,2X,
     & ''F='', G16.9,2X,''G='',E10.3)') NIT,NFV,NFG,F,GMAX
      CALL PYFUT1(NF,F,FO,UMAX,GMAX,DMAX,TOLX,TOLF,TOLB,TOLG,KD,NIT,KIT,
     & MIT,NFV,MFV,NFG,MFG,NTESX,MTESX,NTESF,MTESF,ITES,IRES1,IRES2,
     & IREST,ITERS,ITERM)
      IF (ITERM.NE.0) GO TO 11080
      IF (KBF.GT.0) THEN
      CALL PYRMC0(NF,N,IX,GN,EPS8,UMAX,GMAX,RMAX,IOLD,IREST)
      IF (UMAX.GT.EPS8*GMAX) IREST=MAX(IREST,1)
      END IF
      CALL MXVCOP(NF,X,XO)
11040 CONTINUE
*
*     DIRECTION DETERMINATION
*
      IF (IREST.NE.0) THEN
      IF (KIT.LT.NIT) THEN
      MX=0
      NRES=NRES+1
      KIT = NIT
      ELSE
      ITERM=-10
      IF (ITERS.LT.0) ITERM=ITERS-5
      GO TO 11080
      END IF
      IF (MOS1.GT.1) THEN
      CALL MXVNEG(NF,GN,S)
      GNORM=SQRT(MXUDOT(NF,GN,GN,IX,KBF))
      SNORM=GNORM
      GO TO 12560
      END IF
      END IF
      RHO1=MXUDOT(NF,GN,GN,IX,KBF)
      GNORM=SQRT(RHO1)
      PAR=MIN(EPS,SQRT(GNORM))
      IF (PAR.GT.1.0D 1*1.0D-3) THEN
      PAR=MIN(PAR,1.0D 0/DBLE(NIT))
      END IF
      PAR=PAR*PAR
*
*     CG INITIATION
*
      RHO=RHO1
      SNORM=0.0D 0
      CALL MXVSET(NF,0.0D 0,S)
      CALL MXVNEG(NF,GN,GS)
      CALL MXVCOP(NF,GS,XS)
      IF (MOS2.GT.1) THEN
      IF (MX.EQ.0) THEN
      B=0.0D 0
      ELSE
      B=MXUDOT(NF,XM,GM,IX,KBF)
      ENDIF
      IF (B.GT.0.0D 0) THEN
      U1(1)=1.0D 0/B
      CALL MXDRCB(NF,MX,XM,GM,U1,U2,XS,IX,KBF)
      A=MXUDOT(NF,GM,GM,IX,KBF)
      IF (A.GT.0.0D 0) CALL MXVSCL(NF,B/A,XS,XS)
      CALL MXDRCF(NF,MX,XM,GM,U1,U2,XS,IX,KBF)
      END IF
      END IF
      RHO=MXUDOT(NF,GS,XS,IX,KBF)
C      SIG=RHO
      MMX=NF+3
      NRED=0
12520 CONTINUE
      NRED=NRED+1
      IF (NRED.GT.MMX) GO TO 12550
      FO=F
      PP=SQRT(ETA0/MXUDOT(NF,XS,XS,IX,KBF))
      LD=0
      CALL MXUDIR(NF,PP,XS,XO,X,IX,KBF)
      CALL DOBJ(NF,X,GF)
      NFG=NFG+1
      LD=KD
      CALL MXVDIF(NF,GF,GN,GO)
      F=FO
      CALL MXVSCL(NF,1.0D 0/PP,GO,GO)
      ALF=MXUDOT(NF,XS,GO,IX,KBF)
      IF (ALF.LE.1.0D 0/ETA9) THEN
C      IF (ALF.LE.1.0D-8*SIG) THEN
*
*     CG FAILS (THE MATRIX IS NOT POSITIVE DEFINITE)
*
      IF (NRED.EQ.1) THEN
      CALL MXVNEG(NF,GN,S)
      SNORM=GNORM
      END IF
      ITERD=0
      GO TO 12560
      ELSE
      ITERD=2
      END IF
*
*     CG STEP
*
      ALF=RHO/ALF
      CALL MXUDIR(NF, ALF,XS,S,S,IX,KBF)
      CALL MXUDIR(NF,-ALF,GO,GS,GS,IX,KBF)
      RHO2=MXUDOT(NF,GS,GS,IX,KBF)
      SNORM=SQRT(MXUDOT(NF,S,S,IX,KBF))
      IF (RHO2.LE.PAR*RHO1) GO TO 12560
      IF (NRED.GE.MMX) GO TO 12550
      IF (MOS2.GT.1) THEN
      IF (B.GT.0.0D 0) THEN
      CALL MXVCOP(NF,GS,GO)
      CALL MXDRCB(NF,MX,XM,GM,U1,U2,GO,IX,KBF)
      IF (A.GT.0.0D 0) CALL MXVSCL(NF,B/A,GO,GO)
      CALL MXDRCF(NF,MX,XM,GM,U1,U2,GO,IX,KBF)
      RHO2=MXUDOT(NF,GS,GO,IX,KBF)
      ALF=RHO2/RHO
      CALL MXUDIR(NF,ALF,XS,GO,XS,IX,KBF)
      ELSE
      ALF=RHO2/RHO
      CALL MXUDIR(NF,ALF,XS,GS,XS,IX,KBF)
      END IF
      ELSE
      ALF=RHO2/RHO
      CALL MXUDIR(NF,ALF,XS,GS,XS,IX,KBF)
      END IF
      RHO=RHO2
C      SIG=RHO2+ALF*ALF*SIG
      GO TO 12520
12550 CONTINUE
*
*     AN INEXACT SOLUTION IS OBTAINED
*
12560 CONTINUE
*
*     ------------------------------
*     END OF DIRECTION DETERMINATION
*     ------------------------------
*
      CALL MXVCOP(NF,XO,X)
      CALL MXVCOP(NF,GN,GF)
      IF (KD.GT.0) P=MXUDOT(NF,GN,S,IX,KBF)
      IF (ITERD.LT.0) THEN
        ITERM=ITERD
      ELSE
*
*     TEST ON DESCENT DIRECTION
*
      IF (SNORM.LE.0.0D 0) THEN
        IREST=MAX(IREST,1)
      ELSE IF (P+TOLD*GNORM*SNORM.LE.0.0D 0) THEN
        IREST=0
      ELSE
*
*     UNIFORM DESCENT CRITERION
*
      IREST=MAX(IREST,1)
      END IF
      IF (IREST.EQ.0) THEN
*
*     PREPARATION OF LINE SEARCH
*
        NRED = 0
        RMIN=ALF1*GNORM/SNORM
        RMAX=MIN(ALF2*GNORM/SNORM,XMAX/SNORM)
      END IF
      END IF
      LD=KD
      IF (ITERM.NE.0) GO TO 11080
      IF (IREST.NE.0) GO TO 11040
      CALL PYTRCS(NF,X,IX,XO,XL,XU,GF,GO,S,RO,FP,FO,F,PO,P,RMAX,ETA9,
     & KBF)
      IF (RMAX.EQ.0.0D 0) GO TO 11075
11060 CONTINUE
      CALL PS1L01(R,RP,F,FO,FP,P,PO,PP,FMIN,FMAX,RMIN,RMAX,TOLS,TOLP,
     & PAR1,PAR2,KD,LD,NIT,KIT,NRED,MRED,MAXST,IEST,INITS,ITERS,KTERS,
     & MES,ISYS)
      IF (ISYS.EQ.0) GO TO 11064
      CALL MXUDIR(NF,R,S,XO,X,IX,KBF)
      CALL PCBS04(NF,X,IX,XL,XU,EPS9,KBF)
      CALL OBJ(NF,X,F)
      NFV=NFV+1
      CALL DOBJ(NF,X,GF)
      NFG=NFG+1
      LD=KD
      P=MXUDOT(NF,GF,S,IX,KBF)
      GO TO 11060
11064 CONTINUE
      IF (ITERS.LE.0) THEN
      R=0.0D 0
      F=FO
      P=PO
      CALL MXVCOP(NF,XO,X)
      CALL MXVCOP(NF,GO,GF)
      IREST=MAX(IREST,1)
      LD=KD
      GO TO 11040
      END IF
      CALL PYTRCD(NF,X,IX,XO,GF,GO,R,F,FO,P,PO,DMAX,KBF,KD,LD,ITERS)
      IF (MOS2.GT.1) THEN
      MX=MIN(MX+1,MF)
      CALL MXDRSU(NF,MX,XM,GM,U1)
      CALL MXVCOP(NF,XO,XM)
      CALL MXVCOP(NF,GO,GM)
      END IF
11075 CONTINUE
      IF (KBF.GT.0) THEN
      CALL PYADC0(NF,N,X,IX,XL,XU,INEW)
      IF (INEW.GT.0) IREST=MAX(IREST,1)
      END IF
      GO TO 11020
11080 CONTINUE
      IF (IPRNT.GT.1.OR.IPRNT.LT.0)
     & WRITE(6,'(1X,''EXIT FROM PNET :'')')
      IF (IPRNT.NE.0)
     & WRITE (6,'(1X,''NIT='',I5,2X,''NFV='',I5,2X,''NFG='',I5,2X,
     & ''F='', G16.9,2X,''G='',E10.3,2X,''ITERM='',I3)') NIT,NFV,NFG,
     & F,GMAX,ITERM
      IF (IPRNT.LT.0)
     & WRITE (6,'(1X,''X='',5(G14.7,1X):/(3X,5(G14.7,1X)))')
     & (X(I),I=1,NF)
      RETURN
      END


!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!   Driver for the tangent linear model
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

PROGRAM KPP_ROOT_ADJ_Driver

  USE KPP_ROOT_Model
  USE KPP_ROOT_Initialize, ONLY: Initialize

      KPP_REAL :: T, DVAL(NSPEC)
      INTEGER :: i, j, ind_1 = ind_NO2, ind_2 = ind_O3

! ---  Number of functional for which sensitivities are computed
! ---  Note: this value is set for sensitivities w.r.t. all initial values
! ---       it may have to be changed for other applications
      INTEGER NADJ
      PARAMETER (NADJ = 2)
      KPP_REAL  Y_ADJ(NVAR,NADJ)
      REAL(kind=dble_p)  R1(NVAR), R2(NVAR), V1, V2

! ---- TIME VARIABLES ------------------

      STEPMIN = 0.0d0
      STEPMAX = 0.0d0

      CALL SRAND(89)
      RTOLS = 1.0d-3
      DO i=1,NVAR
        RTOL(i) = RTOLS
        ATOL(i) = 1.0d-2
        R1(i) = 10*(RAND()-0.5d0)
        R2(i) = 10*(RAND()-0.5d0)
      END DO

      CALL Initialize()
! ---  Note: the initial values below are adjoint values at the final time
     Y_ADJ(1:NVAR,1) = R1(1:NVAR)
     Y_ADJ(1:NVAR,2) = R2(1:NVAR)

! ********** T LOOP *************************

      CALL InitSaveData()

      WRITE(6,990) (SPC_NAMES(MONITOR(i)), i=1,NMONITOR)
990   FORMAT('DOne[%] Time[h] ',20(4X,A12))

      T = TSTART

        CALL GetMass( C, DVAL )
        WRITE(6,991) (T-TSTART)/(TEND-TSTART)*100, T/3600.,   &
                    (C(MONITOR(i))/CFACTOR, i=1,NMONITOR),  &
                   (DVAL(i)/CFACTOR, i=1,NMASS)
991     FORMAT(F6.1,'% ',F7.2,3X,20(E10.4,2X))

        CALL SaveData()

        CALL Update_SUN()
        CALL Update_RCONST()

        CALL INTEGRATE_ADJ( NADJ, Y_ADJ, T, TEND )

      V1 = 0.0d0
      V2 = 0.0d0
      DO i=1,NVAR
        V1 = V1 + Y_ADJ(i,1)*R2(i)
        V2 = V2 + Y_ADJ(i,2)*R1(i)
      END DO

      PRINT*,'**************************************************'
      WRITE(6,887) V1
      WRITE(6,888) V2
      WRITE(6,889) ABS(V1-V2)/MAX(ABS(V1),ABS(V2))
887   FORMAT('u.M''*M''.v = ',E24.14 )
888   FORMAT('v.M''*M''.u = ',E24.14 )
889   FORMAT('RelativeErr=',E10.3 )
      PRINT*,'**************************************************'

      CALL GetMass( C, DVAL )
      WRITE(6,991) (T-TSTART)/(TEND-TSTART)*100, T/3600.,    &
                    (C(MONITOR(i))/CFACTOR, i=1,NMONITOR), &
                    (DVAL(i)/CFACTOR, i=1,NMASS)

      CALL SaveData()

! *********** END TIME LOOP ********
      OPEN(20, FILE='KPP_ROOT_ADJ_results.m')
      WRITE(6,*) '**************************************************'
      WRITE(6,*) ' Concentrations and Sensitivities at final time '
      WRITE(6,*) ' were written in the file KPP_ROOT_ADJ_results.m'
      WRITE(6,*) '**************************************************'
      DO j=1,NADJ
        WRITE(20,993) ( Y_ADJ(i,j), i=1,NVAR )
      END DO
 993  FORMAT(1000(E24.16,2X))

      PRINT*,'ADJ: d[',TRIM(SPC_NAMES(ind_1)),'](tf) / d[', &
            TRIM(SPC_NAMES(ind_1)),'](t0)=', Y_ADJ(ind_1,1)
      PRINT*,'ADJ: d[',TRIM(SPC_NAMES(ind_2)),'](tf) / d[', &
            TRIM(SPC_NAMES(ind_2)),'](t0)=', Y_ADJ(ind_2,2)
      PRINT*,'ADJ: d[',TRIM(SPC_NAMES(ind_1)),'](tf) / d[', &
            TRIM(SPC_NAMES(ind_2)),'](t0)=', Y_ADJ(ind_1,2)
      PRINT*,'ADJ: d[',TRIM(SPC_NAMES(ind_2)),'](tf) / d[', &
            TRIM(SPC_NAMES(ind_1)),'](t0)=', Y_ADJ(ind_2,1)

      PRINT*,'TLM: d[NO2](tf) / d[NO2](t0)=  1.714961808143527E-002'
      PRINT*,'TLM: d[ O3](tf) / d[ O3](t0)= -4.447774183920545E-003'
      PRINT*,'TLM: d[NO2](tf) / d[ O3](t0)=  0.897512294491540'
      PRINT*,'TLM: d[ O3](tf) / d[NO2](t0)= -5.543729901774693E-005'

      CALL CloseSaveData()

END PROGRAM KPP_ROOT_ADJ_Driver


   !-------------------------------------------------------
   !
   ! bulk.f90
   !
   ! Description:
   ! ============
   ! Code to compute bulk scattering properties
   ! from BHMIE output based on a size grid from
   ! grid.txt . The numerical quadrature is per-
   ! formed using the Trapezoidal Rule and the
   ! PSD is assumed to be a Gamma distribution.
   !
   ! Record of Revisions:
   ! ====================
   !
   ! Date:        Author:           Description:
   ! =====        =======           ============
   ! 2020-03-12   P. Stegmann       Original Code
   !
   !
   !
   !
   ! Copyright © 2020 Patrick Stegmann
   !
   ! This file is part of ScatteringBase.
   !
   ! ScatteringBase is free software:
   ! you can redistribute it and/or modify it under
   ! the terms of the Apache License as published by
   ! the Apache Software Foundation, either version 2.0
   ! of the License, or (at your option) any later version.
   !
   ! 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 Apache License for more details.
   !
   ! You should have received a copy of the Apache 2.0
   ! License along with this program. If not,
   ! see <https://www.apache.org/licenses/LICENSE-2.0>.
   !
   !-------------------------------------------------------

   PROGRAM MAIN

      IMPLICIT NONE

      ! Data Dictionary:

      ! Computation Parameters:
      INTEGER(KIND=4), PARAMETER :: points = 100
      INTEGER(KIND=4), PARAMETER :: nangles = 1999
      INTEGER(KIND=4), PARAMETER :: nStokes = 4
      ! Physical Parameteers:
      REAL(KIND=8), PARAMETER :: pi = 4.d0*DATAN(1.d0)
      REAL(KIND=8), PARAMETER :: veff = 0.3
      REAL(KIND=8), DIMENSION(points) :: rs
      REAL(KIND=8), DIMENSION(nangles) :: scad
      REAL(KIND=8), DIMENSION(nStokes,nangles) :: phf
      REAL(KIND=8), DIMENSION(nStokes,nangles) :: phfi
      REAL(KIND=8) :: p11, p12, p33, p43
      REAL(KIND=8) :: puf
      CHARACTER(LEN=19), DIMENSION(points) :: chas
      CHARACTER(LEN=55) :: dir
      CHARACTER(LEN=55) :: buf
      CHARACTER(LEN=55) :: Reffchar
      REAL(KIND=8) :: Reff
      REAL(KIND=8) :: cexti
      REAL(KIND=8) :: cscai
      REAL(KIND=8) :: cext
      REAL(KIND=8) :: csca
      REAL(KIND=8) :: asym
      REAL(KIND=8) :: asymi
      REAL(KIND=8) :: deltar
      REAL(KIND=8) :: dpl
      REAL(KIND=8) :: rci
      REAL(KIND=8) :: rc
      REAL(KIND=8) :: csc
      INTEGER(KIND=4) :: ii, jj, isca

      ! Instructions:

      ! Read effective radius as command line argument:
      CALL GET_COMMAND_ARGUMENT(1,Reffchar)
      READ(Reffchar,*) Reff

      ! Read the quadrature grid of the particle size from file
      OPEN(10,FILE='grid.txt',ACTION='READ',STATUS='OLD')
      READ(10,*) chas
      REWIND(10)
      READ(10,*) rs
      CLOSE(10)

      ! Read the scattering angles
      dir = TRIM(ADJUSTL(chas(1)))//'/mie_output.txt'
      !dir = 'mie_output.txt'
	  OPEN(12,FILE=dir,ACTION='READ',STATUS='OLD')
      ! Read the header to blank
      DO isca = 1, 6
         READ(12,*)
      END DO
      ! Read the actual scattering angle table
      DO isca = 1, nangles
         READ(12,*) scad(isca)
      END DO
      CLOSE(12)

      rc = 0.d0
      phf = 0.d0
      cext = 0.d0
      csca = 0.d0
      asym = 0.d0

      ! Loop over all particle radii (quadrature points)
      ! for one effective radius:
      DO ii = 1, points
         ! Compute the abscissa spacing
         ! delta_r of the quadrature.
         IF (ii .EQ. 1) THEN
            deltar = rs(1)
         ELSE
            deltar = rs(ii) - rs(ii-1)
         ENDIF
         ! Gamma Dist. PSD integration factor:
         dpl = 1.d0/(rs(ii)**4.d0)
         dpl = rs(ii)**((1-3.*veff)/veff)*EXP(-rs(ii)/(veff*Reff))
         ! Total integration factor:
         rci = deltar * dpl
         rc = rc + rci
         ! Open single-scattering results:
         dir = TRIM(ADJUSTL(chas(ii)))//'/mie_output.txt'
         !dir = 'mie_output.txt'
		 OPEN(11,FILE=dir,ACTION='READ',STATUS='OLD')
         ! Skip header:
         DO isca = 1, 3
            READ(11,*)
         END DO
         ! Read extinction, scattering efficiency,
         ! and asymmetry parameter:
         READ(11,*) buf, cexti, buf, cscai, buf, puf, buf, asymi
         ! Convert efficiency factors to cross-sections:
         cexti = cexti*pi*rs(ii)**2
         cscai = cscai*pi*rs(ii)**2
         ! Average of extinction and scattering cross-sections
         cext = cext + rci * cexti
         csca = csca + rci * cscai
         asym = asym + rci * asymi * cscai
         rci = rci * cscai
         ! Read the phase matrix header to blank:
         DO isca = 1, 2
            read(11,*)
         END DO
         ! Read the entire single-scattering phase matrix from file:
         DO isca = 1, nangles
            READ(11,*) puf, phfi(1:4,isca)
         END DO
         CLOSE(11)
         ! Normalization of phase function
         csc = 0.d0
         DO isca = 1, (nangles-1)
            csc = csc + 0.25d0 * (cos(scad(isca)*pi/180.d0)&
                      - cos(scad(isca+1)*pi/180.d0))*(phfi(1,isca)&
                      + phfi(1,isca+1))
         END DO
         phfi(2,:) = phfi(2,:)*phfi(1,:)
         phfi = phfi / csc
         ! WRITE(*,*) phfi(1,1), csc, rci
         DO isca = 1, nangles
            phf(1:4, isca) = phf(1:4, isca) + rci * phfi(1:4, isca)
         END DO
      END DO
!
      cext = cext/rc
      csca = csca/rc
      phf = phf/rc
      phf = phf/csca
      asym = asym/rc
      csc = 0.d0
      DO isca = 1, (nangles-1)
         csc = csc + 0.25d0 * (cos(scad(isca)*pi/180.d0)&
                   - cos(scad(isca+1)*pi/180.d0))*(phf(1,isca)&
                   + phf(1,isca+1))
      END DO
      !WRITE(*,*) csc, csca, cext

      DO isca = 1, nangles
         phf(2:4,isca) = phf(2:4,isca)/phf(1,isca)
      END DO

      ! Write results to file:
      OPEN(13,FILE='sca_mie.dat',ACTION='WRITE',STATUS='UNKNOWN')
      WRITE(13,'(E16.8,1X,A)') cext, 'extinction coefficient'
      WRITE(13,'(E16.8,1X,A)') csca/cext, 'single-scattering albedo'
      WRITE(13,'(E16.8,1X,A)') asym/csca, 'asymmetry factor'
      DO isca = 1, nangles
         WRITE(13,'(7(E14.6,1X))') scad(isca),phf(1,isca),phf(2,isca),&
                                              phf(3,isca),phf(4,isca)
      END DO
      CLOSE(13)

   END PROGRAM MAIN


      subroutine cplxcalc(node,ix,complex_conc)
!***********************************************************************
!  Copyright, 2004,  The  Regents  of the  University of California.
!  This program was prepared by the Regents of the University of
!  California at Los Alamos National Laboratory (the University) under
!  contract No. W-7405-ENG-36 with the U.S. Department of Energy (DOE).
!  All rights in the program are reserved by the DOE and the University.
!  Permission is granted to the public to copy and use this software
!  without charge, provided that this Notice and any statement of
!  authorship are reproduced on all copies. Neither the U.S. Government
!  nor the University makes any warranty, express or implied, or
!  assumes any liability or responsibility for the use of this software.
!**********************************************************************
!D1
!D1 PURPOSE
!D1
!D1 To compute the concentration of the aqueous complexes
!D1
!**********************************************************************
!D2
!D2 REVISION HISTORY
!D2
!D2 FEHM Version 2.0, SC-194
!D2
!D2 Initial implementation: ?, Programmer: Hari Viswanathan
!D2 new reaction method using chemical components
!D2
!D2 $Log:   /pvcs.config/fehm90/src/cplxcalc.f_a  $
!D2
!D2    Rev 2.5   06 Jan 2004 10:42:46   pvcs
!D2 FEHM Version 2.21, STN 10086-2.21-00, Qualified October 2003
!D2
!D2    Rev 2.4   29 Jan 2003 09:01:02   pvcs
!D2 FEHM Version 2.20, STN 10086-2.20-00
!D2
!D2    Rev 2.3   14 Nov 2001 13:08:02   pvcs
!D2 FEHM Version 2.12, STN 10086-2.12-00
!D2
!D2    Rev 2.2   06 Jun 2001 13:22:58   pvcs
!D2 FEHM Version 2.11, STN 10086-2.11-00
!D2
!D2    Rev 2.1   30 Nov 2000 11:59:04   pvcs
!D2 FEHM Version 2.10, STN 10086-2.10-00
!D2
!D2    Rev 2.0   Fri May 07 14:40:18 1999   pvcs
!D2 FEHM Version 2.0, SC-194 (Fortran 90)
!D2
!**********************************************************************
!D3
!D3 REQUIREMENTS TRACEABILITY
!D3
!D3 2.3.4 Solute-transport equations
!D3 2.4.6 Multiple, interacting solutes
!D3
!**********************************************************************
!D4
!D4 SPECIAL COMMENTS AND REFERENCES
!D4
!D4 Requirements from SDN: 10086-RD-2.20-00
!D4   SOFTWARE REQUIREMENTS DOCUMENT (RD) for the
!D4   FEHM Application Version 2.20
!D4
!**********************************************************************

      use comchem
      use comdti
      use comdi
      use comrxni
      implicit none

      integer node
      integer ix
      integer ic
      integer in
      real*8 prod,tkeq(200)
      real*8 complex_conc

      prod=1
      do ic = 1, ncpnt
         if(spstoic(ix,ic).ne.0)
     2        prod = prod*cpntsv(ic,node)**spstoic(ix,ic)
      enddo
      if(temp_model(ix).eq.'l')then
         tkeq(ix)=heq(ix,1)+heq(ix,2)*t(node)+heq(ix,3)*t(node)**2
         tkeq(ix)=10**tkeq(ix)
	elseif (temp_model(ix) .eq. 't') then
		tkeq(ix) = heq(ix, 1) + heq(ix, 2) * t(in) + heq(ix, 3) / t(in)
     2		+ heq(ix, 4) * log10(t(in)) + heq(ix, 5) / t(in) ** 2
		tkeq(ix) = 10 ** tkeq(ix)
      else
         tkeq(ix)=ckeq(ix)*exp((heq(ix,1)/gas_const*
     2        (1/(25+temp_conv)-1/(t(node)+temp_conv))))
      endif
      complex_conc = tkeq(ix)*prod
      complex_conc = max(complex_conc, 1.d-90)
      end


C NCLFORTSTART
      subroutine betainc (x,a,b,result)
      implicit none
      double precision x,a,b,result

c NCL: alpha = betainc (x,a,b)
C NCLEND
      double precision dbetaislatec

      result = dbetaislatec(x,a,b)
      return
      end

c -----------------------------------------------
c All funtion names were changed by appending "SLATEC" to them
c I did this to avoid naming conflicts
c ----------------------------------------

      DOUBLE PRECISION FUNCTION DBETAISLATEC (X, PIN, QIN)
C***BEGIN PROLOGUE  DBETAISLATEC
C***PURPOSE  Calculate the incomplete Beta function.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C7F
C***TYPE      DOUBLE PRECISION (BETAI-S, DBETAI-D)
C***KEYWORDS  FNLIB, INCOMPLETE BETA FUNCTION, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C   DBETAI calculates the DOUBLE PRECISION incomplete beta function.
C
C   The incomplete beta function ratio is the probability that a
C   random variable from a beta distribution having parameters PIN and
C   QIN will be less than or equal to X.
C
C     -- Input Arguments -- All arguments are DOUBLE PRECISION.
C   X      upper limit of integration.  X must be in (0,1) inclusive.
C   PIN    first beta distribution parameter.  PIN must be .GT. 0.0.
C   QIN    second beta distribution parameter.  QIN must be .GT. 0.0.
C
C***REFERENCES  Nancy E. Bosten and E. L. Battiste, Remark on Algorithm
C                 179, Communications of the ACM 17, 3 (March 1974),
C                 pp. 156.
C***ROUTINES CALLED  D1MACH, DLBETA, XERDJS
C***REVISION HISTORY  (YYMMDD)
C   770701  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890911  Removed unnecessary intrinsics.  (WRB)
C   890911  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERDJS.  (THJ)
C   920528  DESCRIPTION and REFERENCES sections revised.  (WRB)
C***END PROLOGUE  DBETAI
      DOUBLE PRECISION X, PIN, QIN, ALNEPS, ALNSML, C, EPS, FINSUM, P,
     1  PS, Q, SML, TERM, XB, XI, Y, D1MACH, DLBETASLATEC, P1
      LOGICAL FIRST
      SAVE EPS, ALNEPS, SML, ALNSML, FIRST
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  DBETAI
      IF (FIRST) THEN
         EPS = D1MACH(3)
         ALNEPS = LOG (EPS)
         SML = D1MACH(1)
         ALNSML = LOG (SML)
      ENDIF
      FIRST = .FALSE.
C
cdjs  18 JAN 2016
cdjs  IF (X .LT. 0.D0 .OR. X .GT. 1.D0) CALL XERDJS ('SLATEC/NCL',
cdjs +   'DBETAI','X IS NOT IN THE RANGE (0,1)', 1, 2)
cdjs  IF (PIN .LE. 0.D0 .OR. QIN .LE. 0.D0) CALL XERDJS ('SLATEC/NCL',
cdjs +   'DBETAI', 'P AND/OR Q IS LE ZERO', 2, 2)
C
      IF (X .LT. 0.D0 .OR. X .GT. 1.D0 .OR.
     +    PIN .LE. 0.D0 .OR. QIN .LE. 0.D0) THEN
          DBETAISLATEC = 1.0D30
          RETURN
      END IF
C
      Y = X
      P = PIN
      Q = QIN
      IF (Q.LE.P .AND. X.LT.0.8D0) GO TO 20
      IF (X.LT.0.2D0) GO TO 20
      Y = 1.0D0 - Y
      P = QIN
      Q = PIN
C
 20   IF ((P+Q)*Y/(P+1.D0).LT.EPS) GO TO 80
C
C EVALUATE THE INFINITE SUM FIRST.  TERM WILL EQUAL
C Y**P/BETA(PS,P) * (1.-PS)-SUB-I * Y**I / FAC(I) .
C
      PS = Q - AINT(Q)
      IF (PS.EQ.0.D0) PS = 1.0D0
      XB = P*LOG(Y) - DLBETASLATEC(PS,P) - LOG(P)
      DBETAISLATEC = 0.0D0
      IF (XB.LT.ALNSML) GO TO 40
C
      DBETAISLATEC = EXP (XB)
      TERM = DBETAISLATEC*P
      IF (PS.EQ.1.0D0) GO TO 40
      N = MAX (ALNEPS/LOG(Y), 4.0D0)
      DO 30 I=1,N
        XI = I
        TERM = TERM * (XI-PS)*Y/XI
        DBETAISLATEC = DBETAISLATEC + TERM/(P+XI)
 30   CONTINUE
C
C NOW EVALUATE THE FINITE SUM, MAYBE.
C
 40   IF (Q.LE.1.0D0) GO TO 70
C
      XB = P*LOG(Y) + Q*LOG(1.0D0-Y) - DLBETASLATEC(P,Q) - LOG(Q)
      IB = MAX (XB/ALNSML, 0.0D0)
      TERM = EXP(XB - IB*ALNSML)
      C = 1.0D0/(1.D0-Y)
      P1 = Q*C/(P+Q-1.D0)
C
      FINSUM = 0.0D0
      N = Q
      IF (Q.EQ.DBLE(N)) N = N - 1
      DO 50 I=1,N
        IF (P1.LE.1.0D0 .AND. TERM/EPS.LE.FINSUM) GO TO 60
        XI = I
        TERM = (Q-XI+1.0D0)*C*TERM/(P+Q-XI)
C
        IF (TERM.GT.1.0D0) IB = IB - 1
        IF (TERM.GT.1.0D0) TERM = TERM*SML
C
        IF (IB.EQ.0) FINSUM = FINSUM + TERM
 50   CONTINUE
C
 60   DBETAISLATEC = DBETAISLATEC + FINSUM
 70   IF (Y.NE.X .OR. P.NE.PIN) DBETAISLATEC = 1.0D0 - DBETAISLATEC
      DBETAISLATEC = MAX (MIN (DBETAISLATEC, 1.0D0), 0.0D0)
      RETURN
C
 80   DBETAISLATEC = 0.0D0
      XB = P*LOG(MAX(Y,SML)) - LOG(P) - DLBETASLATEC(P,Q)
      IF (XB.GT.ALNSML .AND. Y.NE.0.0D0) DBETAISLATEC = EXP(XB)
      IF (Y.NE.X .OR. P.NE.PIN) DBETAISLATEC = 1.0D0 - DBETAISLATEC
C
      RETURN
      END
C===> DECK D9LGMC
      DOUBLE PRECISION FUNCTION D9LGMCSLATEC (X)
C***BEGIN PROLOGUE  D9LGMC
C***SUBSIDIARY
C***PURPOSE  Compute the log Gamma correction factor so that
C            LOG(DGAMMA(X)) = LOG(SQRT(2*PI)) + (X-5.)*LOG(X) - X
C            + D9LGMC(X).
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C7E
C***TYPE      DOUBLE PRECISION (R9LGMC-S, D9LGMC-D, C9LGMC-C)
C***KEYWORDS  COMPLETE GAMMA FUNCTION, CORRECTION TERM, FNLIB,
C             LOG GAMMA, LOGARITHM, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C Compute the log gamma correction factor for X .GE. 10. so that
C LOG (DGAMMA(X)) = LOG(SQRT(2*PI)) + (X-.5)*LOG(X) - X + D9lGMC(X)
C
C Series for ALGM       on the interval  0.          to  1.00000E-02
C                                        with weighted error   1.28E-31
C                                         log weighted error  30.89
C                               significant figures required  29.81
C                                    decimal places required  31.48
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  D1MACH, DCSEVL, INITDS, XERDJS
C***REVISION HISTORY  (YYMMDD)
C   770601  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERDJS.  (THJ)
C   900720  Routine changed from user-callable to subsidiary.  (WRB)
C***END PROLOGUE  D9LGMC
      DOUBLE PRECISION X, ALGMCS(15), XBIG, XMAX, DCSEVLSLATEC, D1MACH
      LOGICAL FIRST
      SAVE ALGMCS, NALGM, XBIG, XMAX, FIRST
      DATA ALGMCS(  1) / +.1666389480 4518632472 0572965082 2 D+0      /
      DATA ALGMCS(  2) / -.1384948176 0675638407 3298605913 5 D-4      /
      DATA ALGMCS(  3) / +.9810825646 9247294261 5717154748 7 D-8      /
      DATA ALGMCS(  4) / -.1809129475 5724941942 6330626671 9 D-10     /
      DATA ALGMCS(  5) / +.6221098041 8926052271 2601554341 6 D-13     /
      DATA ALGMCS(  6) / -.3399615005 4177219443 0333059966 6 D-15     /
      DATA ALGMCS(  7) / +.2683181998 4826987489 5753884666 6 D-17     /
      DATA ALGMCS(  8) / -.2868042435 3346432841 4462239999 9 D-19     /
      DATA ALGMCS(  9) / +.3962837061 0464348036 7930666666 6 D-21     /
      DATA ALGMCS( 10) / -.6831888753 9857668701 1199999999 9 D-23     /
      DATA ALGMCS( 11) / +.1429227355 9424981475 7333333333 3 D-24     /
      DATA ALGMCS( 12) / -.3547598158 1010705471 9999999999 9 D-26     /
      DATA ALGMCS( 13) / +.1025680058 0104709120 0000000000 0 D-27     /
      DATA ALGMCS( 14) / -.3401102254 3167487999 9999999999 9 D-29     /
      DATA ALGMCS( 15) / +.1276642195 6300629333 3333333333 3 D-30     /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  D9LGMC
      IF (FIRST) THEN
         NALGM = INITDSSLATEC (ALGMCS, 15, REAL(D1MACH(3)) )
         XBIG = 1.0D0/SQRT(D1MACH(3))
         XMAX = EXP (MIN(LOG(D1MACH(2)/12.D0), -LOG(12.D0*D1MACH(1))))
      ENDIF
      FIRST = .FALSE.
C
      IF (X .LT. 10.D0) CALL XERDJS ('SLATEC/NCL', 'D9LGMC',
     +   'X MUST BE GE 10', 1, 2)
      IF (X.GE.XMAX) GO TO 20
C
      D9LGMCSLATEC = 1.D0/(12.D0*X)
      IF (X.LT.XBIG) D9LGMCSLATEC =DCSEVLSLATEC(2.0D0*(10.D0/X)**2-1.D0,
     1                                          ALGMCS, NALGM) / X
      RETURN
C
 20   D9LGMCSLATEC = 0.D0
      CALL XERDJS ('SLATEC/NCL','D9LGMC','X SO BIG D9LGMC UNDERFLOWS',2,
     +   1)
      RETURN
C
      END
C===> DECK DCSEVL
      DOUBLE PRECISION FUNCTION DCSEVLSLATEC (X, CS, N)
C***BEGIN PROLOGUE  DCSEVL
C***PURPOSE  Evaluate a Chebyshev series.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C3A2
C***TYPE      DOUBLE PRECISION (CSEVL-S, DCSEVL-D)
C***KEYWORDS  CHEBYSHEV SERIES, FNLIB, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C  Evaluate the N-term Chebyshev series CS at X.  Adapted from
C  a method presented in the paper by Broucke referenced below.
C
C       Input Arguments --
C  X    value at which the series is to be evaluated.
C  CS   array of N terms of a Chebyshev series.  In evaluating
C       CS, only half the first coefficient is summed.
C  N    number of terms in array CS.
C
C***REFERENCES  R. Broucke, Ten subroutines for the manipulation of
C                 Chebyshev series, Algorithm 446, Communications of
C                 the A.C.M. 16, (1973) pp. 254-256.
C               L. Fox and I. B. Parker, Chebyshev Polynomials in
C                 Numerical Analysis, Oxford University Press, 1968,
C                 page 56.
C***ROUTINES CALLED  D1MACH, XERDJS
C***REVISION HISTORY  (YYMMDD)
C   770401  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERDJS.  (THJ)
C   900329  Prologued revised extensively and code rewritten to allow
C           X to be slightly outside interval (-1,+1).  (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DCSEVL
      DOUBLE PRECISION B0, B1, B2, CS(*), ONEPL, TWOX, X, D1MACH
      LOGICAL FIRST
      SAVE FIRST, ONEPL
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  DCSEVL
      IF (FIRST) ONEPL = 1.0D0 + D1MACH(4)
      FIRST = .FALSE.
      IF (N .LT. 1) CALL XERDJS ('SLATEC/NCL', 'DCSEVL',
     +   'NUMBER OF TERMS .LE. 0', 2, 2)
      IF (N .GT. 1000) CALL XERDJS ('SLATEC/NCL', 'DCSEVL',
     +   'NUMBER OF TERMS .GT. 1000', 3, 2)
      IF (ABS(X) .GT. ONEPL) CALL XERDJS ('SLATEC/NCL', 'DCSEVL',
     +   'X OUTSIDE THE INTERVAL (-1,+1)', 1, 1)
C
      B1 = 0.0D0
      B0 = 0.0D0
      TWOX = 2.0D0*X
      DO 10 I = 1,N
         B2 = B1
         B1 = B0
         NI = N + 1 - I
         B0 = TWOX*B1 - B2 + CS(NI)
   10 CONTINUE
C
      DCSEVLSLATEC = 0.5D0*(B0-B2)
C
      RETURN
      END
C===> DECK DGAMLM
      SUBROUTINE DGAMLM (XMIN, XMAX)
C***BEGIN PROLOGUE  DGAMLM
C***PURPOSE  Compute the minimum and maximum bounds for the argument in
C            the Gamma function.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C7A, R2
C***TYPE      DOUBLE PRECISION (GAMLIM-S, DGAMLM-D)
C***KEYWORDS  COMPLETE GAMMA FUNCTION, FNLIB, LIMITS, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C Calculate the minimum and maximum legal bounds for X in gamma(X).
C XMIN and XMAX are not the only bounds, but they are the only non-
C trivial ones to calculate.
C
C             Output Arguments --
C XMIN   double precision minimum legal value of X in gamma(X).  Any
C        smaller value of X might result in underflow.
C XMAX   double precision maximum legal value of X in gamma(X).  Any
C        larger value of X might cause overflow.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  D1MACH, XERDJS
C***REVISION HISTORY  (YYMMDD)
C   770601  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERDJS.  (THJ)
C***END PROLOGUE  DGAMLM
      DOUBLE PRECISION XMIN, XMAX, ALNBIG, ALNSML, XLN, XOLD, D1MACH
C***FIRST EXECUTABLE STATEMENT  DGAMLM
      ALNSML = LOG(D1MACH(1))
      XMIN = -ALNSML
      DO 10 I=1,10
        XOLD = XMIN
        XLN = LOG(XMIN)
        XMIN = XMIN - XMIN*((XMIN+0.5D0)*XLN - XMIN - 0.2258D0 + ALNSML)
     1    / (XMIN*XLN+0.5D0)
        IF (ABS(XMIN-XOLD).LT.0.005D0) GO TO 20
 10   CONTINUE
      CALL XERDJS ('SLATEC/NCL', 'DGAMLM', 'UNABLE TO FIND XMIN', 1, 2)
C
 20   XMIN = -XMIN + 0.01D0
C
      ALNBIG = LOG (D1MACH(2))
      XMAX = ALNBIG
      DO 30 I=1,10
        XOLD = XMAX
        XLN = LOG(XMAX)
        XMAX = XMAX - XMAX*((XMAX-0.5D0)*XLN - XMAX + 0.9189D0 - ALNBIG)
     1    / (XMAX*XLN-0.5D0)
        IF (ABS(XMAX-XOLD).LT.0.005D0) GO TO 40
 30   CONTINUE
      CALL XERDJS ('SLATEC/NCL', 'DGAMLM', 'UNABLE TO FIND XMAX', 2, 2)
C
 40   XMAX = XMAX - 0.01D0
      XMIN = MAX (XMIN, -XMAX+1.D0)
C
      RETURN
      END
C===> DECK DGAMMA
      DOUBLE PRECISION FUNCTION DGAMMASLATEC (X)
C***BEGIN PROLOGUE  DGAMMA
C***PURPOSE  Compute the complete Gamma function.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C7A
C***TYPE      DOUBLE PRECISION (GAMMA-S, DGAMMA-D, CGAMMA-C)
C***KEYWORDS  COMPLETE GAMMA FUNCTION, FNLIB, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C DGAMMA(X) calculates the double precision complete Gamma function
C for double precision argument X.
C
C Series for GAM        on the interval  0.          to  1.00000E+00
C                                        with weighted error   5.79E-32
C                                         log weighted error  31.24
C                               significant figures required  30.00
C                                    decimal places required  32.05
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  D1MACH, D9LGMC, DCSEVL, DGAMLM, INITDS, XERDJS
C***REVISION HISTORY  (YYMMDD)
C   770601  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890911  Removed unnecessary intrinsics.  (WRB)
C   890911  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERDJS.  (THJ)
C   920618  Removed space from variable name.  (RWC, WRB)
C***END PROLOGUE  DGAMMA
      DOUBLE PRECISION X, GAMCS(42), DXREL, PI, SINPIY, SQ2PIL, XMAX,
     1  XMIN, Y, D9LGMCSLATEC, DCSEVLSLATEC, D1MACH
      LOGICAL FIRST
C
      SAVE GAMCS, PI, SQ2PIL, NGAM, XMIN, XMAX, DXREL, FIRST
      DATA GAMCS(  1) / +.8571195590 9893314219 2006239994 2 D-2      /
      DATA GAMCS(  2) / +.4415381324 8410067571 9131577165 2 D-2      /
      DATA GAMCS(  3) / +.5685043681 5993633786 3266458878 9 D-1      /
      DATA GAMCS(  4) / -.4219835396 4185605010 1250018662 4 D-2      /
      DATA GAMCS(  5) / +.1326808181 2124602205 8400679635 2 D-2      /
      DATA GAMCS(  6) / -.1893024529 7988804325 2394702388 6 D-3      /
      DATA GAMCS(  7) / +.3606925327 4412452565 7808221722 5 D-4      /
      DATA GAMCS(  8) / -.6056761904 4608642184 8554829036 5 D-5      /
      DATA GAMCS(  9) / +.1055829546 3022833447 3182350909 3 D-5      /
      DATA GAMCS( 10) / -.1811967365 5423840482 9185589116 6 D-6      /
      DATA GAMCS( 11) / +.3117724964 7153222777 9025459316 9 D-7      /
      DATA GAMCS( 12) / -.5354219639 0196871408 7408102434 7 D-8      /
      DATA GAMCS( 13) / +.9193275519 8595889468 8778682594 0 D-9      /
      DATA GAMCS( 14) / -.1577941280 2883397617 6742327395 3 D-9      /
      DATA GAMCS( 15) / +.2707980622 9349545432 6654043308 9 D-10     /
      DATA GAMCS( 16) / -.4646818653 8257301440 8166105893 3 D-11     /
      DATA GAMCS( 17) / +.7973350192 0074196564 6076717535 9 D-12     /
      DATA GAMCS( 18) / -.1368078209 8309160257 9949917230 9 D-12     /
      DATA GAMCS( 19) / +.2347319486 5638006572 3347177168 8 D-13     /
      DATA GAMCS( 20) / -.4027432614 9490669327 6657053469 9 D-14     /
      DATA GAMCS( 21) / +.6910051747 3721009121 3833697525 7 D-15     /
      DATA GAMCS( 22) / -.1185584500 2219929070 5238712619 2 D-15     /
      DATA GAMCS( 23) / +.2034148542 4963739552 0102605193 2 D-16     /
      DATA GAMCS( 24) / -.3490054341 7174058492 7401294910 8 D-17     /
      DATA GAMCS( 25) / +.5987993856 4853055671 3505106602 6 D-18     /
      DATA GAMCS( 26) / -.1027378057 8722280744 9006977843 1 D-18     /
      DATA GAMCS( 27) / +.1762702816 0605298249 4275966074 8 D-19     /
      DATA GAMCS( 28) / -.3024320653 7353062609 5877211204 2 D-20     /
      DATA GAMCS( 29) / +.5188914660 2183978397 1783355050 6 D-21     /
      DATA GAMCS( 30) / -.8902770842 4565766924 4925160106 6 D-22     /
      DATA GAMCS( 31) / +.1527474068 4933426022 7459689130 6 D-22     /
      DATA GAMCS( 32) / -.2620731256 1873629002 5732833279 9 D-23     /
      DATA GAMCS( 33) / +.4496464047 8305386703 3104657066 6 D-24     /
      DATA GAMCS( 34) / -.7714712731 3368779117 0390152533 3 D-25     /
      DATA GAMCS( 35) / +.1323635453 1260440364 8657271466 6 D-25     /
      DATA GAMCS( 36) / -.2270999412 9429288167 0231381333 3 D-26     /
      DATA GAMCS( 37) / +.3896418998 0039914493 2081663999 9 D-27     /
      DATA GAMCS( 38) / -.6685198115 1259533277 9212799999 9 D-28     /
      DATA GAMCS( 39) / +.1146998663 1400243843 4761386666 6 D-28     /
      DATA GAMCS( 40) / -.1967938586 3451346772 9510399999 9 D-29     /
      DATA GAMCS( 41) / +.3376448816 5853380903 3489066666 6 D-30     /
      DATA GAMCS( 42) / -.5793070335 7821357846 2549333333 3 D-31     /
      DATA PI / 3.1415926535 8979323846 2643383279 50 D0 /
      DATA SQ2PIL / 0.9189385332 0467274178 0329736405 62 D0 /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  DGAMMA
      IF (FIRST) THEN
         NGAM = INITDSSLATEC (GAMCS, 42, 0.1*REAL(D1MACH(3)) )
C
         CALL DGAMLM (XMIN, XMAX)
         DXREL = SQRT(D1MACH(4))
      ENDIF
      FIRST = .FALSE.
C
      Y = ABS(X)
      IF (Y.GT.10.D0) GO TO 50
C
C COMPUTE GAMMA(X) FOR -XBND .LE. X .LE. XBND.  REDUCE INTERVAL AND FIND
C GAMMA(1+Y) FOR 0.0 .LE. Y .LT. 1.0 FIRST OF ALL.
C
      N = X
      IF (X.LT.0.D0) N = N - 1
      Y = X - N
      N = N - 1
      DGAMMASLATEC = 0.9375D0 + DCSEVLSLATEC (2.D0*Y-1.D0, GAMCS, NGAM)
      IF (N.EQ.0) RETURN
C
      IF (N.GT.0) GO TO 30
C
C COMPUTE GAMMA(X) FOR X .LT. 1.0
C
      N = -N
      IF (X .EQ. 0.D0) CALL XERDJS ('SLATEC/NCL', 'DGAMMA','X IS 0',4,2)
      IF (X .LT. 0.0 .AND. X+N-2 .EQ. 0.D0) CALL XERDJS ('SLATEC/NCL',
     +   'DGAMMA', 'X IS A NEGATIVE INTEGER', 4, 2)
      IF (X .LT. (-0.5D0) .AND. ABS((X-AINT(X-0.5D0))/X) .LT. DXREL)
     +   CALL XERDJS ('SLATEC/NCL', 'DGAMMA',
     +   'ANSWER LT HALF PRECISION BECAUSE X TOO NEAR NEGATIVE INTEGER',
     +   1, 1)
C
      DO 20 I=1,N
        DGAMMASLATEC = DGAMMASLATEC/(X+I-1 )
 20   CONTINUE
      RETURN
C
C GAMMA(X) FOR X .GE. 2.0 AND X .LE. 10.0
C
 30   DO 40 I=1,N
        DGAMMASLATEC = (Y+I) * DGAMMASLATEC
 40   CONTINUE
      RETURN
C
C GAMMA(X) FOR ABS(X) .GT. 10.0.  RECALL Y = ABS(X).
C
 50   IF (X .GT. XMAX) CALL XERDJS ('SLATEC/NCL', 'DGAMMA',
     +   'X SO BIG GAMMA OVERFLOWS', 3, 2)
C
      DGAMMASLATEC = 0.D0
      IF (X .LT. XMIN) CALL XERDJS ('SLATEC/NCL', 'DGAMMA',
     +   'X SO SMALL GAMMA UNDERFLOWS', 2, 1)
      IF (X.LT.XMIN) RETURN
C
      DGAMMASLATEC = EXP((Y-0.5D0)*LOG(Y)- Y +SQ2PIL +D9LGMCSLATEC(Y))
      IF (X.GT.0.D0) RETURN
C
      IF (ABS((X-AINT(X-0.5D0))/X) .LT. DXREL) CALL XERDJS('SLATEC/NCL',
     +   'DGAMMA',
     +   'ANSWER LT HALF PRECISION, X TOO NEAR NEGATIVE INTEGER', 1, 1)
C
      SINPIY = SIN (PI*Y)
      IF (SINPIY .EQ. 0.D0) CALL XERDJS ('SLATEC/NCL', 'DGAMMA',
     +   'X IS A NEGATIVE INTEGER', 4, 2)
C
      DGAMMASLATEC = -PI/(Y*SINPIY*DGAMMASLATEC)
C
      RETURN
      END
C===> DECK DLBETA
      DOUBLE PRECISION FUNCTION DLBETASLATEC (A, B)
C***BEGIN PROLOGUE  DLBETA
C***PURPOSE  Compute the natural logarithm of the complete Beta
C            function.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C7B
C***TYPE      DOUBLE PRECISION (ALBETA-S, DLBETA-D, CLBETA-C)
C***KEYWORDS  FNLIB, LOGARITHM OF THE COMPLETE BETA FUNCTION,
C             SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C DLBETA(A,B) calculates the double precision natural logarithm of
C the complete beta function for double precision arguments
C A and B.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  D9LGMC, DGAMMA, DLNGAM, DLNREL, XERDJS
C***REVISION HISTORY  (YYMMDD)
C   770701  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERDJS.  (THJ)
C   900727  Added EXTERNAL statement.  (WRB)
C***END PROLOGUE  DLBETA
      DOUBLE PRECISION A, B, P, Q, CORR, SQ2PIL, D9LGMCSLATEC,
     1                 DGAMMASLATEC, DLNGAMSLATEC, DLNRELSLATEC
      EXTERNAL DGAMMASLATEC
      SAVE SQ2PIL
      DATA SQ2PIL / 0.9189385332 0467274178 0329736405 62 D0 /
C***FIRST EXECUTABLE STATEMENT  DLBETA
      P = MIN (A, B)
      Q = MAX (A, B)
C
      IF (P .LE. 0.D0) CALL XERDJS ('SLATEC/NCL', 'DLBETA',
     +   'BOTH ARGUMENTS MUST BE GT ZERO', 1, 2)
C
      IF (P.GE.10.D0) GO TO 30
      IF (Q.GE.10.D0) GO TO 20
C
C P AND Q ARE SMALL.
C
      DLBETASLATEC =
     1      LOG(DGAMMASLATEC(P)*(DGAMMASLATEC(Q)/DGAMMASLATEC(P+Q)) )
      RETURN
C
C P IS SMALL, BUT Q IS BIG.
C
 20   CORR = D9LGMCSLATEC(Q) - D9LGMCSLATEC(P+Q)
      DLBETASLATEC = DLNGAMSLATEC(P) + CORR + P - P*LOG(P+Q)
     1  + (Q-0.5D0)*DLNRELSLATEC(-P/(P+Q))
      RETURN
C
C P AND Q ARE BIG.
C
 30   CORR = D9LGMCSLATEC(P) + D9LGMCSLATEC(Q) - D9LGMCSLATEC(P+Q)
      DLBETASLATEC = -0.5D0*LOG(Q)+ SQ2PIL+ CORR+ (P-0.5D0)*LOG(P/(P+Q))
     1  + Q*DLNRELSLATEC(-P/(P+Q))
      RETURN
C
      END
C===> DECK DLNGAM
      DOUBLE PRECISION FUNCTION DLNGAMSLATEC (X)
C***BEGIN PROLOGUE  DLNGAM
C***PURPOSE  Compute the logarithm of the absolute value of the Gamma
C            function.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C7A
C***TYPE      DOUBLE PRECISION (ALNGAM-S, DLNGAM-D, CLNGAM-C)
C***KEYWORDS  ABSOLUTE VALUE, COMPLETE GAMMA FUNCTION, FNLIB, LOGARITHM,
C             SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C DLNGAM(X) calculates the double precision logarithm of the
C absolute value of the Gamma function for double precision
C argument X.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  D1MACH, D9LGMCSLATEC, DGAMMA, XERDJS
C***REVISION HISTORY  (YYMMDD)
C   770601  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERDJS.  (THJ)
C   900727  Added EXTERNAL statement.  (WRB)
C***END PROLOGUE  DLNGAM
      DOUBLE PRECISION X, DXREL, PI, SINPIY, SQPI2L, SQ2PIL, XMAX,
     1  Y, DGAMMASLATEC, D9LGMCSLATEC, D1MACH, TEMP
      LOGICAL FIRST
      EXTERNAL DGAMMASLATEC
      SAVE SQ2PIL, SQPI2L, PI, XMAX, DXREL, FIRST
      DATA SQ2PIL / 0.9189385332 0467274178 0329736405 62 D0 /
      DATA SQPI2L / +.2257913526 4472743236 3097614947 441 D+0    /
      DATA PI / 3.1415926535 8979323846 2643383279 50 D0 /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  DLNGAM
      IF (FIRST) THEN
         TEMP = 1.D0/LOG(D1MACH(2))
         XMAX = TEMP*D1MACH(2)
         DXREL = SQRT(D1MACH(4))
      ENDIF
      FIRST = .FALSE.
C
      Y = ABS (X)
      IF (Y.GT.10.D0) GO TO 20
C
C LOG (ABS (DGAMMASLATEC(X)) ) FOR ABS(X) .LE. 10.0
C
      DLNGAMSLATEC = LOG (ABS (DGAMMASLATEC(X)) )
      RETURN
C
C LOG ( ABS (DGAMMASLATEC(X)) ) FOR ABS(X) .GT. 10.0
C
 20   IF (Y .GT. XMAX) CALL XERDJS ('SLATEC/NCL', 'DLNGAM',
     +   'ABS(X) SO BIG DLNGAM OVERFLOWS', 2, 2)
C
      IF (X.GT.0.D0) DLNGAMSLATEC = SQ2PIL+(X-0.5D0)*LOG(X)
     +                                     -X+D9LGMCSLATEC(Y)
      IF (X.GT.0.D0) RETURN
C
      SINPIY = ABS (SIN(PI*Y))
      IF (SINPIY .EQ. 0.D0) CALL XERDJS ('SLATEC/NCL', 'DLNGAM',
     +   'X IS A NEGATIVE INTEGER', 3, 2)
C
      IF (ABS((X-AINT(X-0.5D0))/X) .LT. DXREL) CALL XERDJS('SLATEC/NCL',
     +   'DLNGAM',
     +   'ANSWER LT HALF PRECISION BECAUSE X TOO NEAR NEGATIVE INTEGER',
     +   1, 1)
C
      DLNGAMSLATEC = SQPI2L+(X-0.5D0)*LOG(Y)-X
     1                      -LOG(SINPIY)-D9LGMCSLATEC(Y)
      RETURN
C
      END
C===> DECK DLNREL
      DOUBLE PRECISION FUNCTION DLNRELSLATEC (X)
C***BEGIN PROLOGUE  DLNREL
C***PURPOSE  Evaluate ln(1+X) accurate in the sense of relative error.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C4B
C***TYPE      DOUBLE PRECISION (ALNREL-S, DLNREL-D, CLNREL-C)
C***KEYWORDS  ELEMENTARY FUNCTIONS, FNLIB, LOGARITHM
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C DLNREL(X) calculates the double precision natural logarithm of
C (1.0+X) for double precision argument X.  This routine should
C be used when X is small and accurate to calculate the logarithm
C accurately (in the relative error sense) in the neighborhood
C of 1.0.
C
C Series for ALNR       on the interval -3.75000E-01 to  3.75000E-01
C                                        with weighted error   6.35E-32
C                                         log weighted error  31.20
C                               significant figures required  30.93
C                                    decimal places required  32.01
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  D1MACH, DCSEVL, INITDS, XERDJS
C***REVISION HISTORY  (YYMMDD)
C   770601  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERDJS.  (THJ)
C***END PROLOGUE  DLNREL
      DOUBLE PRECISION ALNRCS(43), X, XMIN,  DCSEVLSLATEC, D1MACH
      LOGICAL FIRST
      SAVE ALNRCS, NLNREL, XMIN, FIRST
      DATA ALNRCS(  1) / +.1037869356 2743769800 6862677190 98 D+1     /
      DATA ALNRCS(  2) / -.1336430150 4908918098 7660415531 33 D+0     /
      DATA ALNRCS(  3) / +.1940824913 5520563357 9261993747 50 D-1     /
      DATA ALNRCS(  4) / -.3010755112 7535777690 3765377765 92 D-2     /
      DATA ALNRCS(  5) / +.4869461479 7154850090 4563665091 37 D-3     /
      DATA ALNRCS(  6) / -.8105488189 3175356066 8099430086 22 D-4     /
      DATA ALNRCS(  7) / +.1377884779 9559524782 9382514960 59 D-4     /
      DATA ALNRCS(  8) / -.2380221089 4358970251 3699929149 35 D-5     /
      DATA ALNRCS(  9) / +.4164041621 3865183476 3918599019 89 D-6     /
      DATA ALNRCS( 10) / -.7359582837 8075994984 2668370319 98 D-7     /
      DATA ALNRCS( 11) / +.1311761187 6241674949 1522943450 11 D-7     /
      DATA ALNRCS( 12) / -.2354670931 7742425136 6960923301 75 D-8     /
      DATA ALNRCS( 13) / +.4252277327 6034997775 6380529625 67 D-9     /
      DATA ALNRCS( 14) / -.7719089413 4840796826 1081074933 00 D-10    /
      DATA ALNRCS( 15) / +.1407574648 1359069909 2153564721 91 D-10    /
      DATA ALNRCS( 16) / -.2576907205 8024680627 5370786275 84 D-11    /
      DATA ALNRCS( 17) / +.4734240666 6294421849 1543950059 38 D-12    /
      DATA ALNRCS( 18) / -.8724901267 4742641745 3012632926 75 D-13    /
      DATA ALNRCS( 19) / +.1612461490 2740551465 7398331191 15 D-13    /
      DATA ALNRCS( 20) / -.2987565201 5665773006 7107924168 15 D-14    /
      DATA ALNRCS( 21) / +.5548070120 9082887983 0413216972 79 D-15    /
      DATA ALNRCS( 22) / -.1032461915 8271569595 1413339619 32 D-15    /
      DATA ALNRCS( 23) / +.1925023920 3049851177 8785032448 68 D-16    /
      DATA ALNRCS( 24) / -.3595507346 5265150011 1897078442 66 D-17    /
      DATA ALNRCS( 25) / +.6726454253 7876857892 1945742267 73 D-18    /
      DATA ALNRCS( 26) / -.1260262416 8735219252 0824256375 46 D-18    /
      DATA ALNRCS( 27) / +.2364488440 8606210044 9161589555 19 D-19    /
      DATA ALNRCS( 28) / -.4441937705 0807936898 8783891797 33 D-20    /
      DATA ALNRCS( 29) / +.8354659446 4034259016 2412939946 66 D-21    /
      DATA ALNRCS( 30) / -.1573155941 6479562574 8992535210 66 D-21    /
      DATA ALNRCS( 31) / +.2965312874 0247422686 1543697066 66 D-22    /
      DATA ALNRCS( 32) / -.5594958348 1815947292 1560132266 66 D-23    /
      DATA ALNRCS( 33) / +.1056635426 8835681048 1872841386 66 D-23    /
      DATA ALNRCS( 34) / -.1997248368 0670204548 3149994666 66 D-24    /
      DATA ALNRCS( 35) / +.3778297781 8839361421 0498559999 99 D-25    /
      DATA ALNRCS( 36) / -.7153158688 9081740345 0381653333 33 D-26    /
      DATA ALNRCS( 37) / +.1355248846 3674213646 5020245333 33 D-26    /
      DATA ALNRCS( 38) / -.2569467304 8487567430 0798293333 33 D-27    /
      DATA ALNRCS( 39) / +.4874775606 6216949076 4595199999 99 D-28    /
      DATA ALNRCS( 40) / -.9254211253 0849715321 1323733333 33 D-29    /
      DATA ALNRCS( 41) / +.1757859784 1760239233 2697600000 00 D-29    /
      DATA ALNRCS( 42) / -.3341002667 7731010351 3770666666 66 D-30    /
      DATA ALNRCS( 43) / +.6353393618 0236187354 1802666666 66 D-31    /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  DLNREL
      IF (FIRST) THEN
         NLNREL = INITDSSLATEC (ALNRCS, 43, 0.1*REAL(D1MACH(3)))
         XMIN = -1.0D0 + SQRT(D1MACH(4))
      ENDIF
      FIRST = .FALSE.
C
      IF (X .LE. (-1.D0)) CALL XERDJS ('SLATEC/NCL', 'DLNREL',
     +   'X IS LE -1' , 2, 2)
      IF (X .LT. XMIN) CALL XERDJS ('SLATEC/NCL', 'DLNREL',
     +   'ANSWER LT HALF PRECISION BECAUSE X TOO NEAR -1', 1, 1)
C
      IF (ABS(X).LE.0.375D0) DLNRELSLATEC = X*(1.D0 -
     1  X*DCSEVLSLATEC (X/.375D0, ALNRCS, NLNREL))
C
      IF (ABS(X).GT.0.375D0) DLNRELSLATEC = LOG (1.0D0+X)
C
      RETURN
      END

C===> DECK INITDS
      FUNCTION INITDSSLATEC (OS, NOS, ETA)
C***BEGIN PROLOGUE  INITDS
C***PURPOSE  Determine the number of terms needed in an orthogonal
C            polynomial series so that it meets a specified accuracy.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C3A2
C***TYPE      DOUBLE PRECISION (INITS-S, INITDS-D)
C***KEYWORDS  CHEBYSHEV, FNLIB, INITIALIZE, ORTHOGONAL POLYNOMIAL,
C             ORTHOGONAL SERIES, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C  Initialize the orthogonal series, represented by the array OS, so
C  that INITDS is the number of terms needed to insure the error is no
C  larger than ETA.  Ordinarily, ETA will be chosen to be one-tenth
C  machine precision.
C
C             Input Arguments --
C   OS     double precision array of NOS coefficients in an orthogonal
C          series.
C   NOS    number of coefficients in OS.
C   ETA    single precision scalar containing requested accuracy of
C          series.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  XERDJS
C***REVISION HISTORY  (YYMMDD)
C   770601  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   891115  Modified error message.  (WRB)
C   891115  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERDJS.  (THJ)
C***END PROLOGUE  INITDS
      DOUBLE PRECISION OS(*)
C***FIRST EXECUTABLE STATEMENT  INITDS
      IF (NOS .LT. 1) CALL XERDJS ('SLATEC/NCL', 'INITDS',
     +   'Number of coefficients is less than 1', 2, 1)
C
      ERR = 0.
      DO 10 II = 1,NOS
        I = NOS + 1 - II
        ERR = ERR + ABS(REAL(OS(I)))
        IF (ERR.GT.ETA) GO TO 20
   10 CONTINUE
C
   20 IF (I .EQ. NOS) CALL XERDJS ('SLATEC/NCL', 'INITDS',
     +   'Chebyshev series too short for specified accuracy', 1, 1)
      INITDSSLATEC = I
C
      RETURN
      END
C ++++++++++ DJS CREATED THIS SHORT ROUTINE***********
C ++++++++++ IT REPLACES "XERMSG"          ***********
      SUBROUTINE XERDJS (LIBRAR, SUBROU, MESSG, NERR, LEVEL)
      CHARACTER*(*) LIBRAR, SUBROU, MESSG
      INTEGER       NERR, LEVEL

      LENL = LEN(LIBRAR)
      LENS = LEN(SUBROU)
      LENM = LEN(MESSG)
      PRINT *,"==>", LIBRAR(1:LENL),": ",SUBROU(1:LENS),": "
     +             , MESSG(1:LENM), ": NERR=",NERR
     +             , ": LEVEL=",LEVEL

      RETURN
      END


      subroutine insert(iopt,t,n,c,k,x,tt,nn,cc,nest,ier)
c  subroutine insert inserts a new knot x into a spline function s(x)
c  of degree k and calculates the b-spline representation of s(x) with
c  respect to the new set of knots. in addition, if iopt.ne.0, s(x)
c  will be considered as a periodic spline with period per=t(n-k)-t(k+1)
c  satisfying the boundary constraints
c       t(i+n-2*k-1) = t(i)+per  ,i=1,2,...,2*k+1
c       c(i+n-2*k-1) = c(i)      ,i=1,2,...,k
c  in that case, the knots and b-spline coefficients returned will also
c  satisfy these boundary constraints, i.e.
c       tt(i+nn-2*k-1) = tt(i)+per  ,i=1,2,...,2*k+1
c       cc(i+nn-2*k-1) = cc(i)      ,i=1,2,...,k
c
c  calling sequence:
c     call insert(iopt,t,n,c,k,x,tt,nn,cc,nest,ier)
c
c  input parameters:
c    iopt : integer flag, specifying whether (iopt.ne.0) or not (iopt=0)
c           the given spline must be considered as being periodic.
c    t    : array,length nest, which contains the position of the knots.
c    n    : integer, giving the total number of knots of s(x).
c    c    : array,length nest, which contains the b-spline coefficients.
c    k    : integer, giving the degree of s(x).
c    x    : real, which gives the location of the knot to be inserted.
c    nest : integer specifying the dimension of the arrays t,c,tt and cc
c           nest > n.
c
c  output parameters:
c    tt   : array,length nest, which contains the position of the knots
c           after insertion.
c    nn   : integer, giving the total number of knots after insertion
c    cc   : array,length nest, which contains the b-spline coefficients
c           of s(x) with respect to the new set of knots.
c    ier  : error flag
c      ier = 0 : normal return
c      ier =10 : invalid input data (see restrictions)
c
c  restrictions:
c    nest > n
c    t(k+1) <= x <= t(n-k)
c    in case of a periodic spline (iopt.ne.0) there must be
c       either at least k interior knots t(j) satisfying t(k+1)<t(j)<=x
c       or at least k interior knots t(j) satisfying x<=t(j)<t(n-k)
c
c  other subroutines required: fpinst.
c
c  further comments:
c   subroutine insert may be called as follows
c        call insert(iopt,t,n,c,k,x,t,n,c,nest,ier)
c   in which case the new representation will simply replace the old one
c
c  references :
c    boehm w : inserting new knots into b-spline curves. computer aided
c              design 12 (1980) 199-201.
c   dierckx p. : curve and surface fitting with splines, monographs on
c                numerical analysis, oxford university press, 1993.
c
c  author :
c    p.dierckx
c    dept. computer science, k.u.leuven
c    celestijnenlaan 200a, b-3001 heverlee, belgium.
c    e-mail : Paul.Dierckx@cs.kuleuven.ac.be
c
c  latest update : march 1987
c
c  ..scalar arguments..
      integer iopt,n,k,nn,nest,ier
      real x
c  ..array arguments..
      real t(nest),c(nest),tt(nest),cc(nest)
c  ..local scalars..
      integer kk,k1,l,nk,nk1
c  ..
c  before starting computations a data check is made. if the input data
c  are invalid control is immediately repassed to the calling program.
      ier = 10
      if(nest.le.n) go to 40
      k1 = k+1
      nk = n-k
      if(x.lt.t(k1) .or. x.gt.t(nk)) go to 40
c  search for knot interval t(l) <= x < t(l+1).
      nk1 = nk-1
      l = k1
  10  if(x.lt.t(l+1) .or. l.eq.nk1) go to 20
      l = l+1
      go to 10
  20  if(t(l).ge.t(l+1)) go to 40
      if(iopt.eq.0) go to 30
      kk = 2*k
      if(l.le.kk .and. l.ge.(n-kk)) go to 40
  30  ier = 0
c  insert the new knot.
      call fpinst(iopt,t,n,c,k,x,l,tt,nn,cc,nest)
  40  return
      end


C
C	$Id: msbsf2.f,v 1.5 2008-07-27 00:17:30 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      SUBROUTINE MSBSF2 (DXMIN,DXMAX,MD,DYMIN,DYMAX,ND,DZ,
     *                   IDZ,M,N,XMIN,XMAX,YMIN,YMAX,Z,IZ,
     *                   ZP,WORK,SIGMA)
C
      DIMENSION DZ(IDZ,ND),Z(IZ,N),ZP(M,N,3),WORK(4,MD)
C
C ---------------------------------------------------------------------
C Note:  This routine comes from a proprietary package called FITPACK.
C It is used in the NCAR graphics package by permission of the author,
C Alan Cline.
C ---------------------------------------------------------------------
C
C                                            CODED BY ALAN KAYLOR CLINE
C                                         FROM FITPACK -- JUNE 22, 1986
C                                   A CURVE AND SURFACE FITTING PACKAGE
C                                 A PRODUCT OF PLEASANT VALLEY SOFTWARE
C                             8603 ALTUS COVE, AUSTIN, TEXAS 78759, USA
C
C ---------------------------------------------------------------------
C
C THIS SUBROUTINE MAPS VALUES ONTO A SURFACE AT EVERY POINT
C OF A GRID EQUALLY SPACED IN BOTH X AND Y COORDINATES. THE
C SURFACE INTERPOLATION IS PERFORMED USING A BI-SPLINE UNDER
C TENSION. THE SUBROUTINE MSBSF1 SHOULD BE CALLED EARLIER TO
C DETERMINE CERTAIN NECESSARY PARAMETERS. IN BOTH MSBSF1 AND
C MSBSF2, THE ORIGINAL GRID IS ASSUMED TO BE EQUALLY SPACED
C IN THE X AND Y COORDINATES.
C
C ON INPUT--
C
C   DXMIN AND DXMAX CONTAIN THE LOWER AND UPPER LIMITS,
C   RESPECTIVELY, OF THE X-COORDINATES OF THE SECOND GRID.
C
C   MD CONTAINS THE NUMBER OF GRID LINES IN THE X DIRECTION
C   OF THE SECOND GRID (MD .GE. 1).
C
C   DYMIN AND DYMAX CONTAIN THE LOWER AND UPPER LIMITS,
C   RESPECTIVELY, OF THE Y-COORDINATES OF THE SECOND GRID.
C
C   ND CONTAINS THE NUMBER OF GRID LINES IN THE Y DIRECTION
C   OF THE SECOND GRID (ND .GE. 1).
C
C   IDZ CONTAINS THE ROW DIMENSION OF THE ARRAY DZ AS
C   DECLARED IN THE CALLING PROGRAM.
C
C   M AND N CONTAIN THE NUMBER OF GRID LINES IN THE X- AND
C   Y-DIRECTIONS, RESPECTIVELY, OF THE RECTANGULAR GRID
C   WHICH SPECIFIED THE SURFACE.
C
C   XMIN AND XMAX ARE THE LOWER AND UPPER LIMITS,
C   RESPECTIVELY, OF THE GRID IN THE X DIRECTION.
C
C   YMIN AND YMAX ARE THE LOWER AND UPPER LIMITS,
C   RESPECTIVELY, OF THE GRID IN THE Y DIRECTION.
C
C   Z IS A MATRIX CONTAINING THE M * N FUNCTIONAL VALUES
C   CORRESPONDING TO THE GRID VALUES (I. E. Z(I,J) IS THE
C   SURFACE VALUE AT THE POINT (X(I),Y(J)) FOR I = 1,...,M
C   AND J = 1,...,N, WHERE X(I) REPRESENTS THE I-TH
C   EQUISPACED X VALUE AND Y(J) REPRESENTS THE J-TH
C   EQUISPACED Y VALUE).
C
C   IZ CONTAINS THE ROW DIMENSION OF THE ARRAY Z AS DECLARED
C   IN THE CALLING PROGRAM.
C
C   ZP IS AN ARRAY OF 3*M*N LOCATIONS STORED WITH THE
C   VARIOUS SURFACE DERIVATIVE INFORMATION DETERMINED BY
C   SURF1.
C
C   WORK IS AN ARRAY OF 4*MD LOCATIONS TO BE USED INTERNALLY
C   FOR WORKSPACE.
C
C   SIGMA CONTAINS THE TENSION FACTOR (ITS SIGN IS IGNORED).
C
C THE PARAMETERS M, N, XMIN, XMAX, YMIN, YMAX, Z, IZ, ZP,
C AND SIGMA SHOULD BE INPUT UNALTERED FROM THE OUTPUT OF
C MSBSF1.
C
C ON OUTPUT--
C
C   DZ CONTAINS THE MD BY ND ARRAY OF SURFACE VALUES
C   INTERPOLATED AT THE POINTS OF THE SECOND GRID.
C
C NONE OF THE INPUT PARAMETERS ARE ALTERED.
C
C THIS FUNCTION REFERENCES PACKAGE MODULE MSSHCH.
C
C-----------------------------------------------------------
C
C DENORMALIZE TENSION FACTOR IN X AND Y DIRECTION
C
      SIGMAX = ABS(SIGMA)*REAL(M-1)/(XMAX-XMIN)
      SIGMAY = ABS(SIGMA)*REAL(N-1)/(YMAX-YMIN)
C
C FIND INTERVALS OF SECOND X GRID WITH RESPECT TO ORIGINAL X
C GRID
C
      DELTDX = 0.
      IF (MD .GE. 2) DELTDX = (DXMAX-DXMIN)/REAL(MD-1)
      DELX = (XMAX-XMIN)/REAL(M-1)
      IF (SIGMAX .NE. 0.) CALL MSSHCH (SINHMS,DUMMY,
     *                                 SIGMAX*DELX,-1)
      DO 2 II = 1,MD
        XII = DXMIN+REAL(II-1)*DELTDX
        I = 2+INT((XII-XMIN)/DELX)
        IF (I .LT. 2) I = 2
        IF (I .GT. M) I = M
        DEL1 = XII-XMIN-REAL(I-2)*DELX
        DEL2 = DELX-DEL1
        WORK(1,II) = DEL2/DELX
        WORK(2,II) = DEL1/DELX
        IF (SIGMAX .NE. 0.) GO TO 1
        TEMP = -DEL1*DEL2/(6.*DELX)
        WORK(3,II) = TEMP*(DEL2+DELX)
        WORK(4,II) = TEMP*(DEL1+DELX)
        GO TO 2
    1   CALL MSSHCH (SINHM1,DUMMY,SIGMAX*DEL1,-1)
        CALL MSSHCH (SINHM2,DUMMY,SIGMAX*DEL2,-1)
        TEMP = SIGMAX*SIGMAX*DELX*(1.+SINHMS)
        WORK(3,II) = DEL2*(SINHM2-SINHMS)/TEMP
        WORK(4,II) = DEL1*(SINHM1-SINHMS)/TEMP
    2   CONTINUE
C
C FIND INTERVALS OF SECOND Y GRID WITH RESPECT TO ORIGINAL Y
C GRID AND PERFORM INTRPOLATION
C
      DELTDY = 0.
      IF (ND .GE. 2) DELTDY = (DYMAX-DYMIN)/REAL(ND-1)
      DELY = (YMAX-YMIN)/REAL(N-1)
      IF (SIGMAY .NE. 0.) CALL MSSHCH (SINHMS,DUMMY,
     *                                 SIGMAY*DELY,-1)
      DO 5 JJ=1,ND
        YJJ = DYMIN+REAL(JJ-1)*DELTDY
        J = 2+INT((YJJ-YMIN)/DELY)
        IF (J .LT. 2) J = 2
        IF (J .GT. N) J = N
        JM1 = J-1
        DEL1 = YJJ-YMIN-REAL(J-2)*DELY
        DEL2 = DELY-DEL1
        C1 = DEL2/DELY
        C2 = DEL1/DELY
        IF (SIGMAY .NE. 0.) GO TO 3
        TEMP = -DEL1*DEL2/(6.*DELY)
        C3 = TEMP*(DEL2+DELY)
        C4 = TEMP*(DEL1+DELY)
        GO TO 4
    3   CALL MSSHCH (SINHM1,DUMMY,SIGMAY*DEL1,-1)
        CALL MSSHCH (SINHM2,DUMMY,SIGMAY*DEL2,-1)
        TEMP = SIGMAY*SIGMAY*DELY*(1.+SINHMS)
        C3 = DEL2*(SINHM2-SINHMS)/TEMP
        C4 = DEL1*(SINHM1-SINHMS)/TEMP
    4   LASTI = 0
        DO 5 II=1,MD
          XII = DXMIN+REAL(II-1)*DELTDX
          I = 2+INT((XII-XMIN)/DELX)
          IF (I .LT. 2) I = 2
          IF (I .GT. M) I = M
          IM1 = I-1
          IF (IM1 .EQ. LASTI) GO TO 5
          LASTI = IM1
          ZIM1 = C1*Z(IM1,JM1)+C2*Z(IM1,J)
     *           +C3*ZP(IM1,JM1,1)+C4*ZP(IM1,J,1)
          ZI = C1*Z(I,JM1)+C2*Z(I,J)
     *         +C3*ZP(I,JM1,1)+C4*ZP(I,J,1)
          ZXXIM1 = C1*ZP(IM1,JM1,2)+C2*ZP(IM1,J,2)
     *             +C3*ZP(IM1,JM1,3)+C4*ZP(IM1,J,3)
          ZXXI = C1*ZP(I,JM1,2)+C2*ZP(I,J,2)
     *           +C3*ZP(I,JM1,3)+C4*ZP(I,J,3)
    5     DZ(II,JJ) = WORK(1,II)*ZIM1+WORK(2,II)*ZI
     *                +WORK(3,II)*ZXXIM1+WORK(4,II)*ZXXI
      RETURN
      END


C$Procedure  EDLIMB   ( Ellipsoid Limb )

      SUBROUTINE EDLIMB ( A, B, C, VIEWPT, LIMB )

C$ Abstract
C
C     Find the limb of a triaxial ellipsoid, viewed from a specified
C     point.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     ELLIPSES
C
C$ Keywords
C
C     ELLIPSE
C     ELLIPSOID
C     GEOMETRY
C     MATH
C
C$ Declarations

      INTEGER               UBEL
      PARAMETER           ( UBEL   =    9 )

      DOUBLE PRECISION      A
      DOUBLE PRECISION      B
      DOUBLE PRECISION      C
      DOUBLE PRECISION      VIEWPT (    3 )
      DOUBLE PRECISION      LIMB   ( UBEL )

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     A          I   Length of ellipsoid semi-axis lying on the x-axis.
C     B          I   Length of ellipsoid semi-axis lying on the y-axis.
C     C          I   Length of ellipsoid semi-axis lying on the z-axis.
C     VIEWPT     I   Location of viewing point.
C     LIMB       O   Limb of ellipsoid as seen from viewing point.
C
C$ Detailed_Input
C
C     A,
C     B,
C     C              are the lengths of the semi-axes of a triaxial
C                    ellipsoid.  The ellipsoid is centered at the
C                    origin and oriented so that its axes lie on the
C                    x, y and z axes.  A, B, and C are the lengths of
C                    the semi-axes that point in the x, y, and z
C                    directions respectively.
C
C     VIEWPT         is a point from which the ellipsoid is viewed.
C                    VIEWPT must be outside of the ellipsoid.
C
C$ Detailed_Output
C
C     LIMB           is a SPICELIB ellipse that represents the limb of
C                    the ellipsoid.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     1)  If the length of any semi-axis of the ellipsoid is
C         non-positive, the error SPICE(INVALIDAXISLENGTH) is signalled.
C         LIMB is not modified.
C
C     2)  If the length of any semi-axis of the ellipsoid is zero after
C         the semi-axis lengths are scaled by the reciprocal of the
C         magnitude of the longest semi-axis and then squared, the error
C         SPICE(DEGENERATECASE) is signalled.  LIMB is not modified.
C
C     3)  If the viewing point VIEWPT is inside the ellipse, the error
C         SPICE(INVALIDPOINT) is signalled.  LIMB is not modified.
C
C     4)  If the geometry defined by the input ellipsoid and viewing
C         point is so extreme that the limb cannot be found, the error
C         SPICE(DEGENERATECASE) is signalled.
C
C     5)  If the shape of the ellipsoid and the viewing geometry are
C         such that the limb is an excessively flat ellipsoid, the
C         limb may be a degenerate ellipse.  You must determine whether
C         this possibility poses a problem for your application.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     The limb of a body, as seen from a viewing point, is the boundary
C     of the portion of the body's surface that is visible from that
C     viewing point.  In this definition, we consider a surface point
C     to be `visible' if it can be connected to the viewing point by a
C     line segment that doen't pass through the body.  This is a purely
C     geometrical definition that ignores the matter of which portions
C     of the surface are illuminated, or whether the view is obscured by
C     any additional objects.
C
C     If a body is modelled as a triaxial ellipsoid, the limb is always
C     an ellipse.  The limb is determined by its center, a semi-major
C     axis vector, and a semi-minor axis vector.
C
C     We note that the problem of finding the limb of a triaxial
C     ellipsoid is mathematically identical to that of finding its
C     terminator, if one makes the simplifying assumption that the
C     terminator is the limb of the body as seen from the vertex of the
C     umbra.  So, this routine can be used to solve this simplified
C     version of the problem of finding the terminator.
C
C$ Examples
C
C     1)  We'd like to find the apparent limb of Jupiter, corrected for
C         light time, as seen from a spacecraft's position at time ET.
C
C            C
C            C     Find the viewing point in Jupiter-centered
C            C     coordinates.  To do this, find the apparent position
C            C     of Jupiter as seen from the spacecraft and negate
C            C     this vector.  In this case we'll use light time
C            C     correction to arrive at the apparent limb. JSTAT is
C            C     the Jupiter's state (position and velocity) as seen
C            C     from the spacecraft.  SCPOS is the spacecraft's
C            C     position relative to Jupiter.
C            C
C                  CALL SPKEZ  ( JUPID,  ET, 'J2000', 'LT', SCID,
C                 .              SCSTAT, LT                       )
C
C                  CALL VMINUS ( SCSTAT, SCPOS )
C
C            C
C            C     Get Jupiter's semi-axis lengths...
C            C
C                  CALL BODVCD ( JUPID, 'RADII', 3, N, RAD )
C
C            C
C            C     ...and the transformation from J2000 to Jupiter
C            C     equator and prime meridian coordinates. Note that we
C            C     use the orientation of Jupiter at the time of
C            C     emission of the light that arrived at the
C            C     spacecraft at time ET.
C            C
C                  CALL BODMAT ( JUPID, ET-LT, TIPM )
C
C            C
C            C     Transform the spacecraft's position into Jupiter-
C            C     fixed coordinates.
C            C
C                  CALL MXV ( TIPM, SCPOS, SCPOS )
C
C            C
C            C     Find the apparent limb.  LIMB is a SPICELIB ellipse
C            C     representing the limb.
C            C
C                  CALL EDLIMB ( RAD(1), RAD(2), RAD(3), SCPOS, LIMB )
C
C            C
C            C     LCENTR, SMAJOR, and SMINOR are the limb's center,
C            C     semi-major axis of the limb, and a semi-minor axis
C            C     of the limb.  We obtain these from LIMB using the
C            C     SPICELIB routine EL2CGV ( Ellipse to center and
C            C     generating vectors ).
C            C
C                  CALL EL2CGV ( LIMB, CENTER, SMAJOR, SMINOR )
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     N.J. Bachman   (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.3.0, 23-OCT-2005 (NJB)
C
C        Updated to remove non-standard use of duplicate arguments
C        in VSCLG call.  Updated header to refer to BODVCD instead
C        of BODVAR.
C
C-    SPICELIB Version 1.2.0, 06-OCT-1993 (NJB)
C
C        Declaration of unused local variable NEAR was removed.
C
C-    SPICELIB Version 1.1.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.1.0, 04-DEC-1990 (NJB)
C
C        Error message and description changed for non-positive
C        axis length error.
C
C-    SPICELIB Version 1.0.0, 02-NOV-1990 (NJB)
C
C-&

C$ Index_Entries
C
C     ellipsoid limb
C
C-&

C$ Revisions
C
C-    SPICELIB Version 1.3.0, 23-OCT-2005 (NJB)
C
C        Updated to remove non-standard use of duplicate arguments
C        in VSCLG call.  Updated header to refer to BODVCD instead
C        of BODVAR.
C
C-    SPICELIB Version 1.2.0, 06-OCT-1993 (NJB)
C
C        Declaration of unused local variable NEAR was removed.
C
C-    SPICELIB Version 1.1.0, 04-DEC-1990 (NJB)
C
C        Error message and description changed for non-positive
C        axis length error.  The former message and description did
C        not match, and the description was incorrect:  it described
C        `zero-length', rather than `non-positive' axes as invalid.
C
C-&

C
C     SPICELIB functions
C
      LOGICAL               RETURN

C
C     Local parameters
C
      INTEGER               UBPL
      PARAMETER           ( UBPL   =    4 )

C
C     Local variables
C
      DOUBLE PRECISION      LEVEL
      DOUBLE PRECISION      LPLANE ( UBPL )
      DOUBLE PRECISION      NORMAL (    3 )
      DOUBLE PRECISION      SCALE
      DOUBLE PRECISION      SCLA
      DOUBLE PRECISION      SCLA2
      DOUBLE PRECISION      SCLB
      DOUBLE PRECISION      SCLB2
      DOUBLE PRECISION      SCLC
      DOUBLE PRECISION      SCLC2
      DOUBLE PRECISION      TMPEL  ( UBEL )
      DOUBLE PRECISION      V      (    3 )

      LOGICAL               FOUND

C
C     Standard SPICE error handling.
C
      IF ( RETURN () ) THEN
         RETURN
      ELSE
         CALL CHKIN ( 'EDLIMB' )
      END IF

C
C     The semi-axes must have positive length.
C
      IF (       ( A .LE. 0.D0 )
     .     .OR.  ( B .LE. 0.D0 )
     .     .OR.  ( C .LE. 0.D0 )   )   THEN

         CALL SETMSG ( 'Semi-axis lengths:  A = #, B = #, C = #. ' )
         CALL ERRDP  ( '#', A                                      )
         CALL ERRDP  ( '#', B                                      )
         CALL ERRDP  ( '#', C                                      )
         CALL SIGERR ( 'SPICE(INVALIDAXISLENGTH)'                  )
         CALL CHKOUT ( 'EDLIMB'                                    )
         RETURN

      END IF

C
C     Scale the semi-axes lengths for better numerical behavior.
C     If squaring any one of the scaled lengths causes it to
C     underflow to zero, we cannot continue the computation. Otherwise,
C     scale the viewing point too.
C
      SCALE  =  MAX ( DABS(A), DABS(B), DABS(C) )

      SCLA   =  A / SCALE
      SCLB   =  B / SCALE
      SCLC   =  C / SCALE

      SCLA2  =  SCLA**2
      SCLB2  =  SCLB**2
      SCLC2  =  SCLC**2

      IF (       ( SCLA2  .EQ.  0.D0 )
     .     .OR.  ( SCLB2  .EQ.  0.D0 )
     .     .OR.  ( SCLC2  .EQ.  0.D0 )   )   THEN

         CALL SETMSG ( 'Semi-axis too small:  A = #, B = #, C = #. ' )
         CALL ERRDP  ( '#', A                                        )
         CALL ERRDP  ( '#', B                                        )
         CALL ERRDP  ( '#', C                                        )
         CALL SIGERR ( 'SPICE(DEGENERATECASE)'                       )
         CALL CHKOUT ( 'EDLIMB'                                      )
         RETURN

      END IF

      CALL VSCL ( 1.0D0 / SCALE, VIEWPT, V )

C
C     The viewing point must be outside of the ellipsoid.  LEVEL is the
C     constant of the level surface that V lies on.  The ellipsoid
C     itself is the level surface corresponding to LEVEL = 1.
C
      LEVEL   =     ( V(1)**2 / SCLA2 )
     .           +  ( V(2)**2 / SCLB2 )
     .           +  ( V(3)**2 / SCLC2 )

      IF ( LEVEL .LT. 1.D0 ) THEN

         CALL SETMSG ( 'Viewing point is inside the ellipsoid.' )
         CALL SIGERR ( 'SPICE(DEGENERATECASE)'                  )
         CALL CHKOUT ( 'EDLIMB'                                 )
         RETURN

      END IF

C
C     Find a normal vector for the limb plane.
C
C     To compute this vector, we use the fact that the surface normal at
C     each limb point is orthogonal to the line segment connecting the
C     viewing point and the limb point.   Let the notation
C
C        < a, b >
C
C     indicate the dot product of the vectors a and b.  If we call the
C     viewing point V and the limb point X, then
C
C
C
C                            X(1)         X(2)         X(3)
C        0  =   < V - X,  ( -------- ,   -------- ,   --------  )  >
C                                2           2             2
C                            SCLA        SCLB          SCLC
C
C
C                            X(1)         X(2)         X(3)
C           =   <   V,    ( -------- ,   -------- ,   --------  )  >
C                                2           2             2
C                            SCLA        SCLB          SCLC
C
C
C                            X(1)         X(2)         X(3)
C            - <   X,    ( -------- ,   -------- ,   --------  )  >
C                                2           2             2
C                            SCLA        SCLB          SCLC
C
C                                2           2             2
C                            X(1)        X(2)          X(3)
C           =             --------  +   --------  +  --------
C                               2            2             2
C                           SCLA         SCLB          SCLC
C
C
C           =   1
C
C
C     This last equation is just the equation of the scaled ellipsoid.
C     We can combine the last two equalities and interchange the
C     positions of X and V to obtain
C
C
C                      V(1)         V(2)         V(3)
C        <   X,    ( -------- ,   -------- ,   --------  )  >   =   1
C                          2           2             2
C                      SCLA        SCLB          SCLC
C
C
C     This is the equation of the limb plane.
C

C
C     Put together a SPICELIB plane, LPLANE, that represents the limb
C     plane.
C
      NORMAL(1)  =  V(1) / SCLA2
      NORMAL(2)  =  V(2) / SCLB2
      NORMAL(3)  =  V(3) / SCLC2

      CALL NVC2PL ( NORMAL, 1.0D0, LPLANE )

C
C     Find the limb by intersecting the limb plane with the ellipsoid.
C
      CALL INEDPL ( SCLA,  SCLB,  SCLC,  LPLANE,  LIMB,  FOUND )

C
C     FOUND should be true unless we've encountered numerical problems.
C
      IF ( .NOT. FOUND ) THEN

         CALL SETMSG ( 'Ellipsoid shape and viewing geometry are too '//
     .                 'extreme; the limb was not found. '             )
         CALL SIGERR ( 'SPICE(DEGENERATECASE)'                         )
         CALL CHKOUT ( 'EDLIMB'                                        )
         RETURN

      END IF

C
C     Undo the scaling before returning the limb.
C
      CALL VSCLG ( SCALE, LIMB, UBEL, TMPEL )
      CALL MOVED ( TMPEL, UBEL,       LIMB  )

      CALL CHKOUT ( 'EDLIMB' )
      RETURN
      END