C ----------------------------------------------------------------------!-------
      SUBROUTINE TTANH5
C ----------------------------------------------------------------------!-------
!  9 Dec 2010 - C array no longer overlays T array
!  4 May 2009 - replaced REAL*8 with DOUBLE PRECISION
! 17 Sep 2004 - changed TANH to DTANH
C ----------------------------------------------------------------------!-------
C     TEMPERATURE 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 TEMPERATURE DATA.
C     REFERENCE TEMPERATURE T0 IS READ FROM TABULAR DATA.
      implicit double precision (a-h,o-z)
C     COMMON DECK "RKAM" INSERTED HERE
      DOUBLE PRECISION KR,KTH,KPH                                  !  4 May 2009 
      COMMON//R,TH,PH,KR,KTH,KPH,RKVARS(14),TPULSE,CSTEP,DRDT(20)
C     COMMON DECK "TT" INSERTED HERE
      DOUBLE PRECISION MODT                                        !  4 May 2009 
      COMMON/TT/MODT(4), T,PTT,PTR,PTTH,PTPH
C     COMMON DECK "WW" INSERTED HERE
      COMMON/WW/ dum(10),MAXW,W(1000)
      EQUIVALENCE (EARTHR,W(1))

C     TEMPERATURE    200-224
      EQUIVALENCE (W(200),TMODEL),(W(201),TFORM),(W(202),TID)

C     COMMON DECK "B5" INSERTED HERE
      INTEGER TMX,TNTBL,TITBL,TFRMTBL,IDST(10)
      COMMON/B5/TMX,TNTBL(10),TITBL(10),TFRMTBL(10),TGP(262)
      EQUIVALENCE (TGP,IDST),(ANT,TGP(11))
C.......The changes from the Cyber version indicated in lower case 
C.......below enlarge the data arrays to accommodate 100 profile points.
      DOUBLE PRECISION c(100), tm(99), z(99), dl(99)               !  4 May 2009 
!  9 Dec 2010       EQUIVALENCE (Z0,TGP(12)),(C,tgp(112))
      EQUIVALENCE (Z0,TGP(12)),(T0,tgp(112))                       !  9 Dec 2010 
      EQUIVALENCE (Z,TGP(13)),(TM,tgp(113)),(DL,tgp(213))
      INTEGER TPX,TQTBL(10),TLTBL(10),TIRMTBL(10)
      DATA TQTBL/1,11,312,7*0/
      DATA TLTBL/1,100,8*0/   
      DATA TIRMTBL/1,2,8*0/  
      DATA RECOGT,N/7.d0,0/
      DATA AQT/0.d0/
      DATA TPX/2/   

C%      COSH (X) = (EXP (X) + 1.d0 / (dEXP (X))) / 2.d0 ! not needed

C ----------------------------------------------------------------------!-------
      ENTRY SETTMP                                                 ! Called once
      ANT=AQT       
      TMX=TPX       
      CALL IMOVE(TNTBL,TQTBL,10)  
      CALL IMOVE(TITBL,TLTBL,10) 
      CALL IMOVE(TFRMTBL,TIRMTBL,10)
      CALL SETPTMP
      RETURN     

C ----------------------------------------------------------------------!-------
      ENTRY ITEMP                         ! Called when a new W array is read in

      CALL IPTEMP
C     IF HAD PREVIOUS CALL BUT NOTHING THIS TIME, EXIT NOW
C     RETAINING PREVIOUS TABULAR DATA COUNT
      IF(N.GT.0 .AND. ANT.EQ.0.d0) RETURN

      IF(idint(RECOGT) .NE. idint(TMODEL))
     1    CALL RERROR('TEMP   ','WRNG MODEL',RECOGT)

      MODT(1)='TTANH5'
      MODT(2)=TID

      N=(ANT+1)/3 - 2
      avl=float(n)
      IF(N .LE. 0)
     1    CALL RERROR('TTANH5','BAD N VALUE',avl)

      ANT=0.d0
C     CONVERT 'T' ARRAY INPUT(OVERLAYS 'C' ARRAY) TO 'C' ARRAY
!  9 Dec 2010       T0=C(1)
      TIM1=T0
      ZIM1=Z0
      NP1=N+1
      DO 10 I=1,NP1
         TI=TM(I)
         ZI=Z(I)
         C(I)=(TI-TIM1)/(ZI-ZIM1)
         TIM1=TI
10       ZIM1=ZI

      RETURN

C ----------------------------------------------------------------------!-------
      ENTRY TEMP
      H = R - EARTHR
      SUM = 0.d0

C     LOOP TO SUM OVER ALL COEFFICIENTS
C     USE SPECIAL FUNCTION 'ALCOSH' WHICH ALLOWS FOR LARGE ARGUMENTS.
      DO 1 I = 1, N
   1  SUM = SUM + DL(I) * (C(I + 1) - C(I)) / 2.d0 *(ALCOSH((H - Z
     1(I)) / DL(I)) - ALCOSH((Z(I)-Z0) / DL(I)))
      T = T0 + SUM + (C(1) + C(N + 1)) * (H - Z0) * 0.5d0
      SUM = 0.d0
      DO 2 I = 1, N
   2  SUM = SUM + (C(I + 1) - C(I)) / 2.d0 * (1.d0 + dTANH ((H - Z(I)) 
     1 /DL(I)))                                                    ! 17 Sep 2004
      PTT=0.d0
      PTR = C(1) + SUM
      PTTH=0.d0
      PTPH=0.d0

      CALL PTEMP
      RETURN
C ----------------------------------------------------------------------!-------
      END SUBROUTINE TTANH5
C ----------------------------------------------------------------------!-------


