C-----------------------------------------------------------------------------
      SUBROUTINE CSTANH  
C-----------------------------------------------------------------------------
C     SPEED PROFILE REPRESENTED BY A SEQUENCE OF LINEAR SEGMENTS   
C     SMOOTHLY JOINED BY HYPERBOLIC FUNCTIONS. PARAMETERS ARE INPUT
C     AS TABULAR DATA WITH SLOPES COMPUTED FROM SPEED DATA.        
      implicit double precision (a-h,o-z)
      INTEGER CPX,CQTBL(10) ,CLTBL(10),CIRMTBL(10)
C     COMMON DECK "RKAM" INSERTED HERE   
      DOUBLE PRECISION KR,KTH,KPH
      COMMON//R,TH,PH,KR,KTH,KPH,RKVARS(14),TPULSE,CSTEP,DRDT(20)  
C     COMMON DECK "B3" INSERTED HERE
      INTEGER CMX,CNTBL,CITBL,CFRMTBL,IDSC(10)
      COMMON/B3/CMX,CNTBL(10),CITBL(10),CFRMTBL(10),CGP(512)
      EQUIVALENCE (CGP,IDSC),(ANC,CGP(11))
C     COMMON DECK "CC" INSERTED HERE 
      DOUBLE PRECISION MODC
      COMMON/CC/MODC(4),CS,PCST,PCSR,PCSTH,PCSPH 
C     COMMON DECK "CONST" INSERTED HERE 
      COMMON/PCONST/CREF,RGAS,GAMMA 
      COMMON/MCONST/PI,PIT2,PID2,DEGS,RAD,ALN10  
      COMMON/WW/ dum(10), MAXW,W(1000)
      EQUIVALENCE (EARTHR,W(1))
C     SOUND SPEED 150-174 
      EQUIVALENCE (W(153),REFC)
C.......The changes from the Cyber version indicated in lower case 
C.......below enlarge the data arrays to accommodate 100 profile points.
      DOUBLE PRECISION alc(100),z(99),b(99),dl(99)
      equivalence (z0,cgp(12)),(cs0,cgp(112)),(dl0,cgp(212))
      equivalence (z,cgp(13)),(b,cgp(113)),(dl,cgp(213))
      data cqtbl/1,11,312,7*0/
      data cltbl/1,100,8*0/
      DATA CIRMTBL/1,2,8*0/
      DATA N/0/
      DATA PFST,PFSTH,PFSPH/3*0.0/
      DATA AQC/0.0/
      DATA CPX/2/ 
C
C
      ENTRY SETSPD  
      PCST=PFST     
      PCSTH=PFSTH   
      PCSPH=PFSPH   
      ANC=AQC       
      CALL IMOVE(CMX,CPX, 1)
      CALL IMOVE(CNTBL,CQTBL,10)
      CALL IMOVE(CITBL,CLTBL,10)
      CALL IMOVE(CFRMTBL,CIRMTBL,10)
      CALL SETPSP 
      RETURN
C
      ENTRY ISPEED
      IF(REFC.GT.0.0) CREF=REFC 
      CALL IPSPEED
C     IF HAD PREVIOUS CALL BUT NOTHING THIS TIME, EXIT NOW
C     RETAINING PREVIOUS TABULAR DATA COUNT  
      IF(N.GT.0 .AND. ANC.EQ.0.d0) RETURN 
      IF(W(150) .NE. 2.) THEN
           PRINT*,' Model check number mismatch: '
           STOP ' W(150) should be 2 if you are using model CSTANH.'
      ENDIF

      MODC(1)=8HCSTANH   
      MODC(2)= w(152)
      N=ANC/3 
      IF(ANC.NE.3*N.OR.N.LE.0) then
           PRINT*,' ERROR in CSTANH.  Invalid number of points = ',N
           STOP   ' at entry ISPEED.'
      endif
      N=N-2 
      ANC=0.d0
C     CONVERT 'C' ARRAY INPUT (OVERLAYS 'B' ARRAY) TO 'B' ARRAY
      ZM1=Z0
      CS0=CS0*CS0
      CSM1=CS0 
      NP1=N+1  
      DO 10 I=1,NP1
         ZR=Z(I)   
         ALC(I)=ALCOSH((ZR-Z0) / DL(I))  
         CS=B(I)*b(i)
         B(I)=(CS-CSM1)/(ZR-ZM1) 
         ZM1=ZR 
10       CSM1=CS
      RETURN    
C
      ENTRY SPEED
      anc=n
      IF(N.LE.0) then
           PRINT*,' ERROR in CSTANH.  Invalid number of points = ',N
           STOP   ' at entry SPEED.'
      endif
      ZR=R-EARTHR 
      SUM = 0.d0  
      PCSR=B(1)   
      DO 1 I = 1, N
      SAV=0.5d0*(B(I+1)-B(I))
      PCSR= PCSR+ SAV * (1.d0+dTANH ((ZR-Z(I)) /DL(I)))
   1  SUM = SUM+DL(I) * SAV *(ALCOSH((ZR-Z(I))/DL(I))-ALC(I))
      CS = CS0+SUM + 0.5d0*(B(1) + B(N + 1)) * (ZR-Z0) 
C
      CALL PSPEED
      RETURN  
      END 


