C-----------------------------------------------------------------------------
      SUBROUTINE MUARDC   
C-----------------------------------------------------------------------------
C 13 Mar 2008 - Corrected length in common block /MM/
C 13 Mar 2008 - Corrected length in common block /PCONST/
C 13 Mar 2008 - Corrected length in common block /RIN/
C  9 Mar 2007 - Added molecular weights to /pconst/
C 26 Feb 2007 - According to page 19 of the "U.S. Standard Atmosphere 1976,"
C               these formulas for viscosity do not apply above 86 km in height.
C 23 Feb 2007 - Added some references.
C 23 Feb 2007 - Changed the definition of APH to be an attenuation coefficient
C               in amplitude instead of in power
C     24 Jul 2006
C     18 Oct 2003
C     17 December 2002, version to use with pcharpo
C     6 May 2003 - error corrected in calculation of aph
C     13 June 2003 - corrected sqrt to dsqrt in calculation of aph
C     ARDC BACKGROUND ABSORPTION FORMULA
C-----------------------------------------------------------------------------
      implicit double precision (a-h,o-z)
C
C     COMMON DECK "RKAM" INSERTED HERE                                  
      DOUBLE PRECISION KR,KTH,KPH,KV
      COMMON//R,TH,PH,KR,KTH,KPH,RKVARS(14),TPULSE,CSTEP,DRDT(20)       
C
C     COMMON DECK "WW" INSERTED HERE
      PARAMETER (NWARSZ=1000)
      COMMON/WW/ dum(10),MAXW,W(NWARSZ)
      EQUIVALENCE (EARTHR,W(1)),(OW,W(6))
C
      EQUIVALENCE (W(503),BETAV),(W(504),SUTH),(W(505),PRNDTL) 
C
C     COMMON DECK "RINREAL" INSERTED HERE
      LOGICAL SPACE
      DOUBLE PRECISION LPOLAR,LPOLRI,KPHK,KPHKI,KAY2,KAY2I
     & , kz2a,kz2ai,kzb,kzbi                         ! 16 Mar 2006 ! 13 Mar 2008
      CHARACTER DISPM*6,modrin*64
      COMMON/RINPL/DISPM 
      COMMON /RIN/ MODRIN,RAYNAME(2,3),TYPE(3),SPACE
      COMMON/RIN/OMEGMIN,OMEGMAX,KAY2,KAY2I
     & , kz2a,kz2ai,kzb,kzbi                         ! 16 Mar 2006 ! 13 Mar 2008
     1 ,            H,HI,PHT,PHTI,PHR,PHRI,PHTH,PHTHI,PHPH,PHPHI
     2, PHOW,PHOWI,PHKR,PHKRI,PHKTH,PHKTI, PHKPH,PHKPI 
     3 ,KPHK,KPHKI,POLAR,POLARI,LPOLAR,LPOLRI,SGN 

C     COMMON DECK "LL" INSERTED HERE                           
      DOUBLE PRECISION MODL
      COMMON/LL/MODL(4),APH,APHPT,APHPR,APHPTH,APHPPH 
C
C     COMMON DECK "AA" INSERTED HERE
      DOUBLE PRECISION MODA
      DOUBLE PRECISION MU,MUPT,MUPR,MUPTH,MUPPH
      DOUBLE PRECISION KAP,KAPPT,KAPPR,KAPPTH,KAPPPH
      COMMON/AA/MODA(4),MU,MUPT,MUPR,MUPTH,MUPPH
      COMMON/AA/KAP,KAPPT,KAPPR,KAPPTH,KAPPPH
C
C     COMMON DECK "CONST" INSERTED HERE
      COMMON/PCONST/CREF,RGAS,GAMMA
     1 ,MO2,MN2,MO,MN,MH2O,MO3 ! 9 Mar 2007
      DOUBLE PRECISION MO2,MN2,MO,MN,MH2O,MO3                      ! 13 Mar 2008
      COMMON/MCONST/PI,PIT2,PID2,DEGS,RAD,ALN10
C
C     COMMON DECK "UU" INSERTED HERE                                    
      DOUBLE PRECISION MODU                                             
      COMMON/UU/MODU(4)                                                 
     1  ,V  ,PVT  ,PVR  ,PVTH  ,PVPH                                    
     2  ,VR ,PVRT ,PVRR ,PVRTH ,PVRPH                                   
     3  ,VTH,PVTHT,PVTHR,PVTHTH,PVTHPH                                  
     4  ,VPH,PVPHT,PVPHR,PVPHTH,PVPHPH                                  
C
C     COMMON DECK "PP" INSERTED HERE
      DOUBLE PRECISION MODP
      COMMON/PP/MODP(4),P,PPT,PPR,PPTH,PPPH
C
C     COMMON DECK "TT" INSERTED HERE
      DOUBLE PRECISION MODT
      COMMON/TT/MODT(4), T,PTT,PTR,PTTH,PTPH
C
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 ! 13 Mar 2008
C
C     COMMON DECK "CB17" INSERTED HERE                
      INTEGER VMX,VNTBL,VITBL,VFRMTBL,IDSV(10)        
      COMMON/B17/VMX,VNTBL(10),VITBL(10),VFRMTBL(10),VGP(53)
      EQUIVALENCE (VGP,IDSV),(ANV,VGP(11))                  
      INTEGER VPX    ,VQTBL(10),VLTBL(10),VIRMTBL(10)       
      DATA VPX/1/         
      DATA VQTBL/1,11,8*0/
      DATA VLTBL/1,9*0/   
      DATA VIRMTBL/1,9*0/ 
C                         
      ENTRY SETABS        
      VMX=VPX                       
      CALL IMOVE(VNTBL,VQTBL,10)    
      CALL IMOVE(VITBL,VLTBL,10)    
      CALL IMOVE(VFRMTBL,VIRMTBL,10)
	call SETPRES
      CALL SETPAB                   
      RETURN                        
C                                   
      ENTRY IABSRP                  
      IF(W(500) .NE. 2.) THEN
           PRINT*,' Model check number mismatch: '
           STOP ' W(500) should be 2 if you are using model MUARDC.'
      endif
C
      MODL(1)=8HMUARDC                             
      MODL(2)= w(502)
	call IPRES
      CALL IPABSRP                                 
      RETURN                                       
C                                                  
      ENTRY ABSRP                                  
C mu from U.S. Standard Atmosphere, 1976, NOAA, NASA, USAF, U.S. Govt. 
C printing office, Washington, D.C., October 1976, page 19.
      MU=BETAV*T**1.5d0/(SUTH+T)
C kap from Gossard and Hooke, page 233.
      KAP=GAMMA*RGAS*MU/((GAMMA-1.d0)*M*PRNDTL)
      GMS=GAMMA-1.d0                                    
C     WIND VELOCITY                                                     
      CALL WINDR                                                        
      KV=KR*VR+KTH*VTH+KPH*VPH                                          
      OWI=OW-KV                                                         
C     PRESSURE
      CALL PRES
C The first version below will duplicate the published error for the sample
C case in the HARPA report.
C      APH=(OW/(GAMMA*P))*(4./3.*MU+GMS*GMS*M/(GAMMA*RGAS)*KAP)
	APH=(OWI/(GAMMA*P))*(4./3.*MU+GMS*GMS*M/(GAMMA*RGAS)*KAP)
     1 *dsqrt(kay2)/ 2.d0 ! 23 Feb 2007 
C 23 Feb 2007 - I divided the above formula by 2.
C The formula for absorption coefficient from viscosity mu is from 
C Gossard and Hooke, (1975), Waves in the Atmosphere, p. 230.  For 
C absorption coefficient in terms of conductivity, kap, p. 233.
      CALL PABSRP       
      END               
