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