C ----------------------------------------------------------------------!-------
C     Ttanh6.for
C ----------------------------------------------------------------------!-------
!  9 Dec 2010 - C array no longer overlays T array
C     30 Apr 2006 - trying something
C     26 Jan 2006 - 
C     25 Jan 2006 - Changed name to Ttanh6.for
C     24 Jan 2006 - different entry points for acoustics and gravity
C     23 January 2006, version for gravity waves
C     28 April 2004
C     ttanh6 is the same as ttanh5 except that the profile is calculated 
C     using a general purpose hyperbolic tangent subroutine, FTANH
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.
C ----------------------------------------------------------------------!-------
      SUBROUTINE temp
C ----------------------------------------------------------------------!-------
      IMPLICIT double precision (a-h,o-z)

      TYPE :: model
         CHARACTER :: model_name
         REAL(KIND=8) :: data_id
         CHARACTER :: pert_name
         REAL(KIND=8) :: pert_id
      END TYPE model
      TYPE (model) :: modtg

      TYPE :: values_and_derivs_1_2
         REAL(KIND=8) :: value
         REAL(KIND=8) :: ptm,pr,pth,pph
         REAL(KIND=8) :: ptmtm,prtm,pthtm,pphtm
         REAL(KIND=8) :: ptmr,prr,pthr,pphr
         REAL(KIND=8) :: ptmth,prth,pthth,pphth
         REAL(KIND=8) :: ptmph,prph,pthph,pphph
      END TYPE 
      TYPE (values_and_derivs_1_2) :: temperature

      REAL(KIND=8) :: KR,KTH,KPH
      COMMON//R,TH,PH,KR,KTH,KPH,RKVARS(14),TPULSE,CSTEP,DRDT(20)
C     COMMON DECK "TT" INSERTED HERE
      REAL(KIND=8) :: MODT

      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))
      REAL(KIND=8) :: c(100), tm(99), z(99), dl(99), dlc(100),
     1 alc(100), dc(100)
c      EQUIVALENCE (Z0,TGP(12)),(C,tgp(112))                       ! 30 Apr 2006
c      EQUIVALENCE (Z,TGP(13)),(TM,tgp(113)),(DL,tgp(213))         ! 30 Apr 2006
!  9 Dec 2010       EQUIVALENCE (Z0,TGP(12)),(C(1),tgp(112))       ! 30 Apr 2006
      EQUIVALENCE (Z0,TGP(12)),(T0,tgp(112))                       !  9 Dec 2010 
      EQUIVALENCE (Z(1),TGP(13)),(TM(1),tgp(113)),(DL(1),tgp(213)) ! 30 Apr 2006
      INTEGER TPX,TQTBL(10),TLTBL(10),TIRMTBL(10)
      DATA n/0/

c      PRINT *,' tsave = ', tsave
c      PRINT *,' savet = ', savet
c      PRINT *,' asavet = ', asavet
      h = r - earthr
c      PRINT *,' r = ', r
c      PRINT *,' earthr = ', earthr
c      PRINT *,' h = ', h
c      PRINT *,' n = ', n
c      PRINT *,' z0 = ', z0
c      PRINT *,' t0 = ', t0
c      PRINT *,' z = ', z
c      PRINT *,' dl = ', dl
c      PRINT *,' c = ', c
      CALL ftanh(h,T,pTr,n,z0,z,t0,dl,c,CAV,DLC,ALC,DC)            ! 24 Jan 2006
c      PRINT *,'T = ',T

      pTt = 0.d0                                                   ! 24 Jan 2006
      pTth = 0.d0                                                  ! 24 Jan 2006
      pTph = 0.d0                                                  ! 24 Jan 2006

      CALL ptemp                                                   ! 24 Jan 2006
      RETURN

C ----------------------------------------------------------------------!-------
      ENTRY tempg(temperature)                                     ! 24 Jan 2006
C ----------------------------------------------------------------------!-------

c      PRINT *,' at tempg, t0 = ', t0
      h = r - earthr
      CALL ftanh2(h,T,pTr,pTrr,n,z0,z,t0,dl,c,CAV,DLC,ALC,DC)
c      PRINT *,' at tempg, t0 = ', t0
      temperature%value = T

      temperature%ptm = 0.d0
      temperature%pr = pTr
      temperature%pth = 0.d0
      temperature%pph = 0.d0

      temperature%ptmtm = 0.d0
      temperature%prtm = 0.d0
      temperature%pthtm = 0.d0
      temperature%pphtm = 0.d0

      temperature%ptmr = 0.d0
      temperature%prr = pTrr
      temperature%pthr = 0.d0
      temperature%pphr = 0.d0

      temperature%ptmth = 0.d0
      temperature%prth = 0.d0
      temperature%pthth = 0.d0
      temperature%pphth = 0.d0

      temperature%ptmph = 0.d0
      temperature%prph = 0.d0
      temperature%pthph = 0.d0
      temperature%pphph = 0.d0

c      PRINT *,'T = ',T
c      PRINT *,'pTr = ',pTr
c      PRINT *,'pTrr = ',temperature%prr


      CALL ptempg(temperature)                                     ! 24 Jan 2006
      RETURN

C ----------------------------------------------------------------------!-------
      ENTRY itemp                                                  ! 24 Jan 2006
C ----------------------------------------------------------------------!-------
C     This subroutine is called once for each new W array.

      CALL iptemp                                                  ! 24 Jan 2006

C     If had previous call but nothing this time, exit now
C     Retaining previous tabular data count
      IF (n > 0 .AND. ant == 0.d0) RETURN                          ! 25 Jan 2006

      IF (Tmodel /= 8.d0) THEN                                     ! 25 Jan 2006
         PRINT *,' Model check number mismatch: '
         STOP ' W(200) should be 8 if you are using model Ttanh6.' ! 25 Jan 2006
      ENDIF

      modt(1) = 'Ttanh6'                                           ! 25 Jan 2006
      modt(2) = Tid                                                ! 24 Jan 2006

      n = (ant+1)/3 - 2
c      PRINT *,' n = ', n
      avl = float(n)
c      PRINT *,' avl = ', avl
      IF (n < 0) CALL RERROR('Ttanh6','BAD N VALUE',avl)           ! 25 Jan 2006

      ant = 0.d0
C     CONVERT 'T' ARRAY INPUT (OVERLAYS 'C' ARRAY) TO 'C' ARRAY
!  9 Dec 2010       T0 = C(1)
c      PRINT *,' t0 = ', t0

      CALL ITANH(N,Z0,Z,T0,TM,DL,C,CAV,DLC,ALC,DC)                 ! 24 Jan 2006
c      PRINT *,' t0 = ', t0
c      tsave = t0
c      savet = t0
c      asavet = t0
c      PRINT *,' tsave = ', tsave
c      PRINT *,' savet = ', savet
c      PRINT *,' asavet = ', asavet
      RETURN

C ----------------------------------------------------------------------!-------
      ENTRY itempg(modtg)                                          ! 26 Jan 2006
C ----------------------------------------------------------------------!-------
C     This subroutine is called once for each new W array.
      CALL iptempg(modtg)                                          ! 24 Jan 2006

C     If had previous call but nothing this time, exit now
C     Retaining previous tabular data count
      IF (n >= 0 .AND. ant == 0.d0) RETURN

      IF (tmodel /= 8.d0) THEN                                     ! 25 Jan 2006
         PRINT *,' Model check number mismatch: '
         STOP ' W(200) should be 8 if you are using model Ttanh6.' ! 26 Jan 2006
      ENDIF

      modtg%model_name = 'Ttanh6'                                  ! 25 Jan 2006
      modtg%data_id = Tid

      n = (ant+1)/3 - 2
      avl = float(n)
      IF (n < 0) CALL RERROR('Ttanh6','BAD N VALUE',avl)           ! 25 Jan 2006

      ant = 0.d0
C     CONVERT 'T' ARRAY INPUT (OVERLAYS 'C' ARRAY) TO 'C' ARRAY
!  9 Dec 2010       T0 = C(1)

      CALL ITANH2(N,Z0,Z,T0,TM,DL,C,CAV,DLC,ALC,DC)

      RETURN
C ----------------------------------------------------------------------!-------
      END SUBROUTINE temp
C ----------------------------------------------------------------------!-------

C ----------------------------------------------------------------------!-------
      SUBROUTINE setTmp
C ----------------------------------------------------------------------!-------
C     This subroutine is called once.

      IMPLICIT double precision (a-h,o-z)

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))
      REAL(KIND=8) :: c(100), tm(99), z(99), dl(99), dlc(100),
     1 alc(100), dc(100)
      EQUIVALENCE (Z0,TGP(12)),(C,tgp(112))
      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 aqt/0.d0/
      DATA tpx/2/

      anT = aqT
      Tmx = Tpx       

      CALL imove(TNTBL,TQTBL,10)
      CALL imove(TITBL,TLTBL,10) 
      CALL imove(TFRMTBL,TIRMTBL,10)
      CALL setpTmp                                                 ! 24 Jan 2006

      RETURN
C ----------------------------------------------------------------------!-------
      END SUBROUTINE setTmp
C ----------------------------------------------------------------------!-------
