
C-----------------------------------------------------------------------------
      SUBROUTINE WGAUSS2  
C-----------------------------------------------------------------------------
C 13 Mar 2008 - Corrected length in common block /PCONST/
C-----------------------------------------------------------------------------
C     WIND VELOCITY MODEL 
C     EXPONENTIALLY DECAYING EFFECT IN ALL THREE DIRECTIONS
C     COMMON DECK "CONST" INSERTED HERE        
      implicit double precision (a-h,o-z)
      COMMON/PCONST/CREF,RGAS,GAMMA      
     1 ,MO2,MN2,MO,MN,MH2O,MO3                        ! 9 Mar 2007 ! 13 Mar 2008
      DOUBLE PRECISION MO2,MN2,MO,MN,MH2O,MO3                      ! 13 Mar 2008
      COMMON/MCONST/PI,PIT2,PID2,DEGS,RAD,ALN10
C     COMMON DECK "RKAM" INSERTED HERE         
      DOUBLE PRECISION KR,KTH,KPH
      COMMON//R,TH,PH,KR,KTH,KPH,RKVARS(14),TPULSE,CSTEP,DRDT(20)
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
      COMMON/WW/ dum(10), MAXW,W(1000)
C     WIND        100-124             
      EQUIVALENCE (EARTHR, W(1))

C     COMMON DECK "B1" INSERTED HERE                          
      INTEGER UMX,UNTBL,UITBL,UFRMTBL,IDSU(10)                
      COMMON/B1/UMX,UNTBL(10),UITBL(10),UFRMTBL(10),UGP(10)   
      EQUIVALENCE (UGP,IDSU)                                  
      INTEGER UPX,UQTBL(10),ULTBL(10),UIRMTBL(10)             
      EQUIVALENCE (UPH0,W(103)),(WH,W(104)),(WTH,W(105))      
      EQUIVALENCE  (WPH,W(106)),(H0,W(107)),(WGTH0,W(108)),(PH0,W(109))
      DATA UPX/1/         
      DATA UQTBL/1,11,8*0/
      DATA ULTBL/1,9*0/   
      DATA UIRMTBL/1,9*0/ 
C                         
      ENTRY SETWND        
      UMX=UPX             
      CALL IMOVE(UNTBL,UQTBL,10) 
      CALL IMOVE(UITBL,ULTBL,10) 
      CALL IMOVE(UFRMTBL,UIRMTBL,10)
      CALL SETPWN   
      RETURN        
C                   
      ENTRY IWINDR  
      IF(W(100) .NE. 8.) THEN
           PRINT*,' Model check number mismatch: '
           STOP ' W(100) should be 8 if you are using model WGAUSS2.'
      endif

      MODU(1)=7HWGAUSS2  
      MODU(2)= w(102)
      CALL IPWINDR       
      WIDH=0.d0          
      WIDTH=0.d0         
      WIDPH=0.d0         
      TH0= PID2-WGTH0    
      IF(WH.NE.0.d0) WIDH=1.d0/WH 
      IF(WTH.NE.0.d0) WIDTH=1.d0/WTH
      IF(WPH.NE.0.d0) WIDPH=1.d0/WPH
      RETURN                        
C                                   
       ENTRY WINDR                  
      CALL CLEAR(V,20)              
       H = R - EARTHR               
      DFH=(H-H0)*WIDH               
      DFTH=(TH-TH0)*WIDTH           
      DFPH=(PH-PH0)*WIDPH           
      EXPO=-(DFH*DFH+DFTH*DFTH+DFPH*DFPH)
      EXPN=0.d0                          
      IF(EXPO.GT.-200.d0) EXPN=dEXP(EXPO)
       VPH = UPH0*EXPN                   
       PVPHR = - 2.d0 * VPH * DFH*WIDH   
       PVPHTH = - 2.d0 * VPH * DFTH*WIDTH
       PVPHPH = - 2.d0 * VPH * DFPH*WIDPH
       END                               
