C ---------------------------------------------------------------------
C MWCONST.for
C ---------------------------------------------------------------------
C     12 Mar 2008 - Declared MGP double precision
C     28 Mar 2007 - Added equivalence of W(253) to subroutine imolwt
C      6 Mar 2007 - Added calculation of molecular weight
C      5 Mar 2007 - Added molecular fractions to common block /MM/
C     13 Jul 2006 - Corrected some errors
C     26 Jan 2006 - Added SUBROUTINE SETMW and corrected some errors
C     25 Jan 2006 - Changed name to MWCONST.FOR
C     24 Jan 2006 - different entry points for acoustics and gravity
C     23 January 2006, version for gravity waves
C ---------------------------------------------------------------------
C
C     CONSTANT MOLECULAR WEIGHT MODEL
      SUBROUTINE molwt ! 24 January 2006
      IMPLICIT double precision (a-h,o-z)

      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) :: molecular_weight

      PARAMETER (NWARSZ=1000)
      COMMON/WW/dum(10),MAXW,W(NWARSZ)
      DOUBLE PRECISION MMODEL,MFORM,MID

C     MOLECULAR   250-274
      EQUIVALENCE (W(250),MMODEL),(W(251),MFORM),(W(252),MID)

C     COMMON DECK "MM" INSERTED HERE
      DOUBLE PRECISION M,MODM
      COMMON/MM/MODM(4),M,PMT,PMR,PMTH,PMPH
     1 ,XO2,XN2,XO,XN,XH2O,XO3 ! 5 Mar 2007
      DOUBLE PRECISION mlcnst
     1 ,MO2,MN2,MO,MN,MH2O,MO3 ! 6 Mar 2007
      EQUIVALENCE (W(253),mlcnst)
      EQUIVALENCE (W(254),XO2in),(W(255),XN2in),(W(256),XOin)  ! 5 Mar 2007)
     1,(W(257),XNin),(W(258),XH2Oin),(W(259),XMO3in)           ! 5 Mar 2007)
      data MO2,MN2,MO,MN,MH2O,MO3                        ! 6 Mar 2007
     1 /31.9988,28.0134,15.9994,14.0067,18.0153,47.9982/ ! 6 Mar 2007
C Above molecular weights from Sutherland & Bass, JASA 115, 1012-1032 (2004)

C Moved the calculation of M to Subroutine imolwt    ! 6 Mar 2007

c      print*,'Beginning of molwt'

      CALL clear(pmt,4)

      RETURN

      ENTRY molwtg(molecular_weight) ! 24 January 2006

      if(mlcnst.ne.0.) then                                  ! 6 Mar 2007
      molecular_weight%value = mlcnst
      else                                                   ! 6 Mar 2007
      sumX = XO2+XN2+XO+XN+XH2O+XO3                          ! 6 Mar 2007
      molecular_weight%value =                               ! 6 Mar 2007
     1  (XO2*MO2+XN2*MN2+XO*MO+XN*MN+XH2O*MH2O+XO3*MO3)/sumX ! 6 Mar 2007
      endif                                                  ! 6 Mar 2007

      molecular_weight%ptm = 0.d0
      molecular_weight%pr = 0.d0
      molecular_weight%pth = 0.d0
      molecular_weight%pph = 0.d0

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

      molecular_weight%ptmr = 0.d0
      molecular_weight%prr = 0.d0
      molecular_weight%pthr = 0.d0
      molecular_weight%pphr = 0.d0

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

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

      RETURN
      END SUBROUTINE MOLWT

C ---------------------------------------------------------------------

      SUBROUTINE imolwt ! 26 Jan 2006
C     This subroutine is called once for each new W array.
      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) :: modmg

      PARAMETER (NWARSZ=1000)
      COMMON/WW/dum(10),MAXW,W(NWARSZ)
      DOUBLE PRECISION mmodel,mform,mid,mlcnst                  ! 28 Mar 2007

C     MOLECULAR   250-274
      EQUIVALENCE (W(250),mmodel),(W(251),mform),(W(252),mid)
     1,(W(253),mlcnst)                                          ! 28 Mar 2007
      EQUIVALENCE (W(254),XO2in),(W(255),XN2in),(W(256),XOin)    ! 5 Mar 2007
     1,(W(257),XNin),(W(258),XH2Oin),(W(259),XO3in)              ! 5 Mar 2007

C     COMMON DECK "MM" INSERTED HERE
      DOUBLE PRECISION M,MODM
      COMMON/MM/MODM(4),M,PMT,PMR,PMTH,PMPH
     1 ,XO2,XN2,XO,XN,XH2O,XO3                                   ! 5 Mar 2007

C     COMMON DECK "B7" INSERTED HERE
C      INTEGER MMX,MNTBL,MITBL,MFRMTBL,IDSM(10)
C      DOUBLE PRECISION MGP
C      COMMON/B7/MMX,MNTBL(10),MITBL(10),MFRMTBL(10),MGP(10)
C      EQUIVALENCE (MGP,IDSM)
C      DATA MMX/1/
C      DATA MNTBL/1,11,8*0/
C      DATA MITBL/1,9*0/
C      DATA MFRMTBL/1,9*0/

      data MO2,MN2,MO,MN,MH2O,MO3                                ! 6 Mar 2007
     1 /31.9988,28.0134,15.9994,14.0067,18.0153,47.9982/         ! 6 Mar 2007
C Above molecular weights from Sutherland & Bass, JASA 115, 1012-1032 (2004)

c      print*,'Beginning of imolwt'

      IF (mmodel /= 1.d0) THEN
           PRINT*,' Model check number mismatch: '
           STOP' W(250) should be 1 if you are using model MWCONST.'!25 Jan 2006
      ENDIF

      MODM(1) = 'MWCONST' ! 25 Jan 2006
      MODM(2) = MID ! 24 January 2006
      XO2  = XO2in   ! 5 Mar 2007
      XN2  = XN2in   ! 5 Mar 2007
      XO   = XOin    ! 5 Mar 2007
      XN   = XNin    ! 5 Mar 2007
      XH2O = XH2Oin  ! 5 Mar 2007
      XO3  = XO3in   ! 5 Mar 2007
      sumX = XO2+XN2+XO+XN+XH2O+XO3                          ! 6 Mar 2007

C Moved the calculation of M to here from Subroutine molwt   ! 6 Mar 2007

      if(mlcnst.ne.0.) then                                  ! 6 Mar 2007
c      print*,'M before = ',M
      M = mlcnst ! 24 January 2006
c      print*,'M after = ',M
      else                                                   ! 6 Mar 2007
      M=(XO2*MO2+XN2*MN2+XO*MO+XN*MN+XH2O*MH2O+XO3*MO3)/sumX ! 6 Mar 2007
      endif                                                  ! 6 Mar 2007

      RETURN

      ENTRY imolwtg(modmg) ! 24 January 2006
C     This subroutine is called once for each new W array.

      IF (mmodel /= 1.d0) THEN
           PRINT*,' Model check number mismatch: '
           STOP' W(250) should be 1 if you are using model MWCONST.'!25 Jan 2006
      ENDIF

      modmg%model_name = 'MWCONST' ! 25 Jan 2006
      modmg%data_id = MID
      modmg%pert_name = ''
      modmg%pert_id = 0.d0
      XO2  = XO2in   ! 5 Mar 2007
      XN2  = XN2in   ! 5 Mar 2007
      XO   = XOin    ! 5 Mar 2007
      XN   = XNin    ! 5 Mar 2007
      XH2O = XH2Oin  ! 5 Mar 2007
      XO3  = XO3in   ! 5 Mar 2007

      RETURN
      END SUBROUTINE IMOLWT

C------------------------------------------------------------------------------

      SUBROUTINE SETMW ! 26 Jan 2006
C
C     This subroutine is called once.
C
      implicit double precision (a-h,o-z)

C     COMMON DECK "B7" INSERTED HERE
      INTEGER MMX,MNTBL,MITBL,MFRMTBL,IDSM(10) ! 13 Jul 2006
      DOUBLE PRECISION MGP                                         ! 12 Mar 2008
      COMMON/B7/MMX,MNTBL(10),MITBL(10),MFRMTBL(10),MGP(10) ! 13 Jul 2006
      EQUIVALENCE (MGP,IDSM) ! 13 Jul 2006
C
      INTEGER DWMX ,DWNTBL(10),DWITBL(10),DWFRMTB(10)
C
      DATA DWMX/1/
      DATA DWNTBL/1,11,8*0/
      DATA DWITBL/1,9*0/
      DATA DWFRMTB/1,9*0/
C
      MMX=DWMX
      CALL IMOVE(MNTBL,DWNTBL,10)
      CALL IMOVE(MITBL,DWITBL,10)
      CALL IMOVE(MFRMTBL,DWFRMTB,10)
C
      RETURN
C
      END SUBROUTINE SETMW
