      PROGRAM ADM                                                       
C                                                                       
C  *********************************************************************
C  *                                                                   *
C  *    M E S O S C A L E    H Y D R O D Y N A M I C    M O D E L      *
C  *                                                                   *
C  *    PSEUDOSPECTRAL (X,Y) AND FINITE DIFFERENCE (Z), 2-D, 3-D       *
C  *                                                                   *
C  *                                LATEST REVISION 8-13-86            *
C  *                                BY  ZAPHIRIS D. CHRISTIDIS         *
C  *********************************************************************
C                                                                       
      DIMENSION WORK(150000)                                            
      CHARACTER DUMMY                                                   
      CHARACTER*49 LABEL                                                
      CHARACTER*14 VAR(2)                                               
      COMMON/STRCH/ALP,BET,DH,ZH,UG,VG,T1,T2,DUT,TOL,ALPHA,HAMP,BUMP    
      COMMON/LEVEL/KK1,KK2,KK3,KK4,IYHOM,IGEO,IUGX,IVGY,LT0,LT1,ICPU    
      COMMON/LAKE/SX,SIGX,SY,SIGY,ZNOT,SFX,SFY,FLX,FLY,BASE,TSL,H0,ZW,ZL
      COMMON/SOURCE/INIT(2,2),NSOUR(2),IX(2,2),JY(2,2),KZ(2,2),         
     *IVAL(2,2),NSX(2,2),NSY(2,2),NSZ(2,2),ISR(2,2)                     
      COMMON/CPU/CINIT,CINHC,CINVC,CINHT,CINVT,CINPI,CINHU,CINVU,       
     *CINHV,CINVV,CINHW,CINVW,CINPR,CINBL,CINFL,CINMN,TM1,TM18,TM19     
                                                                        
      REAL CPU0,CPU1,WAL0,WAL1                                          
                                                                        
      DATA WORK/150000*0.0/,VAR/' SOURCES/SINKS',' INITIAL CONT'/       
CX00001 CALL MAINIX (1)                                                 
CY00001 CALL MAINIY (1)                                                 
CX60000 CALL CNTINX ()                                                  
CY60000 CALL CNTINY ()                                                  
C                                                                       
C      ===== FOR  BATCH JOBS TAKE THE COMMENT OF THE NEXT TWO LINES ====
C                                                                       
      CALL ELAPSE (WAL0)                                                
      CALL CPUTIM (CPU0)                                                
C                                                                       
      OPEN(1,FILE='APV',STATUS='UNKNOWN')                               
                                                                        
      WRITE(1,1)                                                        
1     FORMAT(1X,
     * 'OUTPUT FOR PERFECT CLUB BENCHMARK: ADM INSTRUMENTED VERSION'/
     *       1X,'$Revision: 1.A.1 $ $Author: psharma $'/)                   
                                                                        
      TM19=1.                                                           
      NWINDX=0                                                          
      DUMMY='N'                                                         
C                                                                       
      NSINKS=0                                                          
      OPEN(6,FILE='APO6',STATUS='UNKNOWN')                              
C     OPEN(7,FILE='GRAPH')                                              
      OPEN(7,FILE='APO7',STATUS='UNKNOWN')                              
C     OPEN(8,FILE='PRINT')                                              
      OPEN(8,FILE='APO8',STATUS='UNKNOWN')                              
C     OPEN(11,FILE='BLMPR')                                             
      OPEN(11,FILE='APO11',STATUS='UNKNOWN')                            
C     OPEN(13,FILE='DUMP')                                              
C     OPEN(13)                                                          
 10   FORMAT(A)                                                         
 20   FORMAT(A)                                                         
      WRITE(6,30)                                                       
      WRITE(8,30)                                                       
 30   FORMAT(////,                                                      
     *10X,'*********************************************************',/,
     *10X,'*********************************************************',/,
     *10X,'*** PROGRAM TO  SOLVE FOR THE  MESOSCALE AND SYNOPTIC ***',/,
     *10X,'*** VARIATIONS OF POTENTIAL TEMPERATURE, U AND V WIND ***',/,
     *10X,'*** COMPONENTS, AND THE MESOSCALE VERTICAL VELOCITY W ***',/,
     *10X,'*** PRESSURE AND DISTRIBUTION OF POLLUTANTS C  HAVING ***',/,
     *10X,'*** SOURCES  Q. THE SYNOPTIC  SCALE COMPONENTS ARE IN ***',/,
     *10X,'*** QUASSI-STEADY STATE BALANCE,  WHILE THE MESOSCALE ***',/,
     *10X,'*** PRESSURE AND VELOCITY  W ARE FOUND DIAGNOSTICALLY ***',/,
     *10X,'*********************************************************',/,
     *10X,'*********************************************************',  
     *////)                                                             
      IF(NWINDX.EQ.0) GOTO 60                                           
      WRITE(6,10) ' NEW RUN <N>, OLD RUN <O>, INTERACTIVE RUN <I> '     
      READ(5,20) DUMMY                                                  
      IF(DUMMY.EQ.' ') DUMMY='N'                                        
      IF(DUMMY.EQ.'O'.OR.DUMMY.EQ.'O') THEN                             
C        OPEN(10,FILE='RUN')                                            
         OPEN(10,FILE='APO10',STATUS='OLD')                             
         READ(10,40) NX,NY,NZ,NT,NTIME,NFILT,NCOUNT,ITY,IB,IK,          
     1   NWINDX,NWINDY,NSINKS,NPRINT,NPSTEP,NGRAPH,NGSTEP ,NSOUR(1),    
     2   NSOUR(2),INIT(1,1),INIT(2,1),INIT(1,2),INIT(2,2),IX(1,1),      
     3   IX(2,1),IX(1,2),IX(2,2),JY(1,1),JY(2,1),JY(1,2),JY(2,2) ,      
     4   KZ(1,1),KZ(2,1),KZ(1,2),KZ(2,2),IVAL(1,1),IVAL(2,1),IVAL(1,2), 
     5   IVAL(2,2),NSX(1,1),NSX(2,1),NSX(1,2),NSX(2,2),NSY(1,1),        
     6   NSY(2,1),NSY(1,2),NSY(2,2),NSZ(1,1),NSZ(2,1),NSZ(1,2),         
     7   NSZ(2,2),ISR(1,1),ISR(2,1),ISR(1,2),ISR(2,2),KK1,KK2,KK3,KK4,  
     8   IYHOM                                                          
         READ(10,50) TSTART,DELTAT,XSTART,DELTAX,DX,YSTART,DELTAY,DY,   
     5   ZSTART,DELTAZ,DZ,ALP,BET,ZH,UG,VG,T1,T2,DUT,TOL,ALPHA,         
     6   SX,SIGX,SY,SIGY,ZNOT,HAMP,BUMP,PHI,DL,SFX,SFY,FLX,FLY,BASE     
 40      FORMAT(I15)                                                    
 50      FORMAT(F20.4)                                                  
         CLOSE(10)                                                      
         GOTO 160                                                       
      ENDIF                                                             
 60   CONTINUE                                                          
      IF(DUMMY.EQ.'N'.OR.DUMMY.EQ.'N') THEN                             
C                                                                       
C  ============   READ RUN DATA FROM A FILE  ===========================
C                                                                       
C        OPEN(9,FILE='DATA')                                            
         OPEN(9,FILE='API9',STATUS='OLD')                               
CX10501 CALL DOINX( 501 )                                               
CY10501 CALL DOINY( 501 )                                               
         DO 70 LABELS=1,7                                               
            READ(9,20) LABEL                                            
            WRITE(6,20) LABEL                                           
 70      CONTINUE                                                       
CX20502 CALL DOOUTX( 502 )                                              
CY20502 CALL DOOUTY( 502 )                                              
         READ(9,90) NX,NY,NZ,NTIME,NFILT,NT,NCOUNT,ITY,IB,IK,           
     1   NWINDX,NWINDY,NSINKS,NPRINT,NPSTEP,NGRAPH,NGSTEP ,NSOUR(1),    
     2   NSOUR(2),INIT(1,1),INIT(2,1),INIT(1,2),INIT(2,2),IX(1,1),      
     3   IX(2,1),IX(1,2),IX(2,2),JY(1,1),JY(2,1),JY(1,2),JY(2,2) ,      
     4   KZ(1,1),KZ(2,1),KZ(1,2),KZ(2,2),IVAL(1,1),IVAL(2,1),IVAL(1,2), 
     5   IVAL(2,2),NSX(1,1),NSX(2,1),NSX(1,2),NSX(2,2),NSY(1,1),        
     6   NSY(2,1),NSY(1,2),NSY(2,2),NSZ(1,1),NSZ(2,1),NSZ(1,2),         
     7   NSZ(2,2),ISR(1,1),ISR(2,1),ISR(1,2),ISR(2,2),KK1,KK2,KK3,KK4,  
     8   IYHOM,IGEO,IUGX,IVGY,LT0,LT1,ICPU                              
CX10503 CALL DOINX( 503 )                                               
CY10503 CALL DOINY( 503 )                                               
C                                                                       
         DO 80 LABELS=1,5                                               
            READ(9,20) LABEL                                            
            WRITE(6,20) LABEL                                           
 80      CONTINUE                                                       
CX20504 CALL DOOUTX( 504 )                                              
CY20504 CALL DOOUTY( 504 )                                              
C                                                                       
         READ(9,100) TSTART,DELTAT,XSTART,DELTAX,DX,YSTART,DELTAY,DY,   
     5   ZSTART,DELTAZ,DZ,ALP,BET,ZH,UG,VG,T1,T2,DUT,TOL,ALPHA,         
     6   SX,SIGX,SY,SIGY,ZNOT,HAMP,BUMP,PHI,DL,SFX,SFY,FLX,FLY,BASE,TSL,
     7   H0,ZW,ZL                                                       
         GOTO 160                                                       
 90      FORMAT(31X,I10)                                                
 100     FORMAT(31X,F17.6)                                              
      ENDIF                                                             
C                                                                       
C     INTERACTIVE PART                                                  
C                                                                       
      WRITE(6,10) ' ENTER NUMBER OF GRID POINTS IN X,Y AND Z'           
      READ(5,*) NX,NY,NZ                                                
      IYHOM=1                                                           
      IF(NY.EQ.1) THEN                                                  
         IYHOM=0                                                        
         WRITE(6,10) ' HOMOGENIOUS  Y DIRECTION? (Y/<N>) '              
         READ(5,20) DUMMY                                               
         IF(DUMMY.EQ.'Y'.OR.DUMMY.EQ.'Y') IYHOM=1                       
      ENDIF                                                             
      WRITE(6,10) ' SPECIFY INITIAL TIME TO     '                       
      READ(5,*) TSTART                                                  
      NFILT=1                                                           
      WRITE(6,10) ' ENTER MOMENTUM DIFFUSIVITY FACTOR (1-8) '           
      READ(5,*) NTIME                                                   
      WRITE(6,10) ' DO YOU WANT TO APPLY FILTERING (<Y>/N)'             
      READ(5,20) DUMMY                                                  
      IF(DUMMY.EQ.'N'.OR.DUMMY.EQ.'N') NFILT=0                          
      WRITE(6,10) ' ENTER DEGREE OF IMPLICIT FILTERING (0-1)'           
      READ(5,*) DL                                                      
C                                                                       
C    TIME DEPENDENT PARAMETERS                                          
C                                                                       
      WRITE(6,10) ' SPECIFY NUMBER OF TIME STEPS   '                    
      READ(5,*) NT                                                      
      WRITE(6,10) ' ENTER LEAPFROG TO EULER INTERCHANE FREQUENCY '      
      READ(5,*) NCOUNT                                                  
      WRITE(6,10) '  SPECIFY TIME STEP DT   '                           
      READ(5,*) DELTAT                                                  
C                                                                       
C     X - DEPENDENT PARAMETERS                                          
C                                                                       
      WRITE(6,10) ' ENTER STARTING VALUE FOR  X '                       
      READ(5,*) XSTART                                                  
      WRITE(6,10) ' ENTER SPACE STEP    DX   '                          
      READ(5,*) DELTAX                                                  
      WRITE(6,10) ' ENTER DIFFUSION COEFFICIENT KX '                    
      READ(5,*) DX                                                      
      WRITE(6,10) ' ENTER X-SYMMETRY, AND SPREAD OF LAKE   '            
      READ(5,*) SX,SIGX                                                 
      WRITE(6,10) ' ENTER X-SYMMETRY, SPREAD OF FILTER AND BASE '       
      READ(5,*) SFX,FLX,BASE                                            
C                                                                       
C      Y-DEPENDENT PARAMETERS                                           
C                                                                       
      PHI=40.0                                                          
      IF(NY.GT.1) THEN                                                  
         WRITE(6,10) ' ENTER STARTING VALUE FOR  Y '                    
         READ(5,*) YSTART                                               
         WRITE(6,10) ' ENTER SPACE STEP   DY    '                       
         READ(5,*) DELTAY                                               
         WRITE(6,10) ' ENTER CENTRAL LATITUDE PHI '                     
         READ(5,*) PHI                                                  
         WRITE(6,10) ' ENTER DIFFUSION COEFFICIENT KY '                 
         READ(5,*) DY                                                   
         WRITE(6,10) ' ENTER Y-SYMMETRY, AND SPREAD OF LAKE   '         
         READ(5,*) SY,SIGY                                              
         WRITE(6,10) ' ENTER Y-SYMMETRY, AND SPREAD OF FILTER '         
         READ(5,*) SFY,FLY                                              
         WRITE(6,10) ' ENTER FOUR LEVELS FOR PRINTING RESULTS '         
         READ(5,*) KK1,KK2,KK3,KK4                                      
                  ELSE                                                  
         SY=2.0                                                         
         SIGY= YSTART+NY*DELTAY                                         
         YSTART=0.                                                      
         DELTAY=.1                                                      
         DY=0.0                                                         
      ENDIF                                                             
C                                                                       
C      FOR Z DEPENDENT PARAMETERS                                       
C                                                                       
      WRITE(6,10) ' ENTER STARTING VALUE FOR  Z '                       
      READ(5,*) ZSTART                                                  
      WRITE(6,10) ' ENTER SPACE STEP    DZ   '                          
      READ(5,*) DELTAZ                                                  
      WRITE(6,10) ' ENTER MINIMUM DIFFUSION COEFFICIENT KZ '            
      READ(5,*) DZ                                                      
      WRITE(6,10) ' VERTICAL SMOOTHING (Y/<N>) '                        
      READ(5,20) DUMMY                                                  
      IF(DUMMY.EQ.'Y'.OR.DUMMY.EQ.'Y') NSINKS=1                         
      WRITE(6,10) ' NUMERICAL SCHEME? PADE=1, CRANK NICOLSON=0'         
      READ(5,*) NWINDY                                                  
      ALPHA=.5                                                          
      IF(NWINDY.EQ.0) THEN                                              
         WRITE(6,10) ' ENTER UPWINDING PARAMETER  '                     
         READ(5,*) ALPHA                                                
      ENDIF                                                             
      WRITE(6,10) ' ENTER HEAT OSCILLATION WAVENUMBER '                 
      READ(5,*) IB                                                      
      WRITE(6,10) ' HORIZONTAL FILTERING TIME STEP (1-10) '             
      READ(5,*) IK                                                      
      WRITE(6,10) ' EQUALLY SPACED Z-POINTS ? (<Y>/N) '                 
      READ(5,20) DUMMY                                                  
      IF(DUMMY.EQ.'N'.OR.DUMMY.EQ.'N') THEN                             
         ITY=1                                                          
         WRITE(6,10) ' ENTER STRECHED PARAMETERS A,B   '                
         READ(5,*) ALP,BET                                              
                                       ELSE                             
         ITY=0                                                          
      ENDIF                                                             
      WRITE(6,10) ' ENTER OBSERVATION HEIGHT OR TOP OF B.L. '           
      READ(5,*) ZH                                                      
      WRITE(6,10) ' ENTER INITIAL MIXING HEIGHT  '                      
      READ(5,*) H0                                                      
      WRITE(6,10) ' ENTER FRACTION OF B.L. TO BE USED AS S.L. '         
      READ(5,*) TSL                                                     
C                                                                       
C       DEFINE DEPENDENT VARIABLES                                      
C                                                                       
      WRITE(6,10) ' ENTER OBSERVED UG, VG '                             
      READ(5,*) UG,VG                                                   
      WRITE(6,10) ' ENTER URBAN CONSTANT ROUGHNESS LENGTH Z0 '          
      READ(5,*) ZNOT                                                    
      WRITE(6,10) ' ENTER LAND AND WATER ROUGHNESS LENGTHS  '           
      READ(5,*) ZL,ZW                                                   
      WRITE(6,10) ' ENTER ITERATION STEP DELTA AND TOLLERANCE '         
      READ(5,*) DUT,TOL                                                 
C                                                                       
      WRITE(6,10) ' ENTER TO,TT '                                       
      READ(5,*) T1,T2                                                   
      WRITE(6,10) ' STEP OF RECALCULATING  UG, VG  TO,TT '              
      READ(5,*) IGEO                                                    
      WRITE(6,10) ' ENTER RATE OF CHANE OF  UG, VG (CM/HOUR) '          
      READ(5,*) IUGX,IVGY                                               
      WRITE(6,10) ' ENTER RATE OF CHANE OF  TO, TT (K/10HOUR) '         
      READ(5,*) LT0,LT1                                                 
      WRITE(6,10) ' ENTER CPU REPORT FREQUENCY '                        
      READ(5,*) ICPU                                                    
      WRITE(6,10) ' ENTER LAND LAKE HEAT AMPLITUDE (K) AND LAG (S) '    
      READ(5,*) HAMP,BUMP                                               
C                                                                       
C    MIXED PARAMETERS                                                   
C    BELOW IF K=1 SPECIFY FOR SOURCES , K=2 FOR INITIAL CONDITIONDS     
C                                                                       
      NWINDX=0                                                          
      NWINDY=0                                                          
CX10505 CALL DOINX( 505 )                                               
CY10505 CALL DOINY( 505 )                                               
      DO 140 K=1,2                                                      
         WRITE(6,150) ' SPECIFY ANY ',VAR(K),' (<Y>/N)? '               
         READ(5,20) DUMMY                                               
         IF(DUMMY.EQ.'N'.OR.DUMMY.EQ.'N') THEN                          
            NSOUR(K)=0                                                  
                                          ELSE                          
            WRITE(6,10) ' SPECIFY THE NUMBER OF ',VAR(K)                
            READ(5,*) NSOUR(K)                                          
            NSOU=NSOUR(K)                                               
            DO 130 L=1,NSOU                                             
               WRITE(6,150) ' TYPE OF',VAR(K),'? (0=DELTA,1=GAUSS) '    
               READ(5,*) INIT(K,L)                                      
               WRITE(6,110) VAR(K),L,'  ENTER LOCATION AND VALUE '      
 110           FORMAT(A,I5,A)                                           
               READ(5,*) IX(K,L),JY(K,L),KZ(K,L),IVAL(K,L)              
               WRITE(6,120) ' #',L,' *** ',IVAL(K,L),' *** LOCATED AT'  
     *         ,IX(K,L),JY(K,L),KZ(K,L)                                 
 120           FORMAT(/,A,I3,A,I12,A,' IX=',I3,' JY=',I3,' KZ=',I3)     
               IF(INIT(K,L).GT.0) THEN                                  
                  WRITE(6,10) ' SPECIFY THE EXTEND IN I,J,K POINTS'     
                  READ(5,*) NSX(K,L),NSY(K,L),NSZ(K,L)                  
                  WRITE(6,10) ' SPECIFY SPREAD IN SIGMA UNITS'          
                  READ(5,*) ISR(K,L)                                    
               ENDIF                                                    
 130        CONTINUE                                                    
         ENDIF                                                          
 140  CONTINUE                                                          
CX20506 CALL DOOUTX( 506 )                                              
CY20506 CALL DOOUTY( 506 )                                              
 150  FORMAT(3A)                                                        
      NPSTEP=2                                                          
      NGSTEP=2                                                          
C                                                                       
C   OUTPUT PARAMETERS                                                   
C                                                                       
      WRITE(6,10) ' DO YOU WANT TO STORE THE RESULTS IN A FILE  (Y/<N>)'
      NPRINT=0                                                          
      READ(5,20) DUMMY                                                  
      IF(DUMMY.EQ.'Y'.OR.DUMMY.EQ.'Y') THEN                             
         NPRINT=1                                                       
         WRITE(6,10) ' ENTER STEP N FOR PRINT (EVERY OTHER N)'          
         READ(5,*) NPSTEP                                               
      ENDIF                                                             
      WRITE(6,10) ' DO YOU WANT TO STORE THE RESULTS FOR GRAPH (Y/<N>)' 
      NGRAPH=0                                                          
      READ(5,20) DUMMY                                                  
      IF(DUMMY.EQ.'Y'.OR.DUMMY.EQ.'Y') THEN                             
         NGRAPH=1                                                       
         WRITE(6,10) ' ENTER STEP N FOR GRAPH (EVERY OTHER N)'          
         READ(5,*) NGSTEP                                               
      ENDIF                                                             
 160  CONTINUE                                                          
C                                                                       
C     CHECK FOR A CRUDE STABILITY SATISFACTION AND HEAT CONSTANTS       
C                                                                       
      CALL STAB(NX,NY,NTIME,TSTART,NT,IB,HAMP,BUMP,DELTAX,DELTAY,DELTAT)
C                                                                       
      CALL CPUCLK(TM1,0,0.0)                                            
C                                                                       
C    CALL SUBROUTINE    PSET    TO CARRY OUT THE CALCULATIONS.          
C                                                                       
      CALL PSET(NX,NY,NZ,NT,NTIME,NWINDX,NWINDY,NSINKS,NFILT,           
     *XSTART,YSTART,ZSTART,TSTART,DELTAX,DELTAY,DELTAZ,DELTAT,PHI,DL,   
     *DX,DY,DZ,WORK,IB,IK,ITY,NCOUNT,NPRINT,NGRAPH,NPSTEP,NGSTEP)       
C                                                                       
C     OBTAIN STATISTICS ABOUT THE PARTIAL CPU'S                         
C                                                                       
      TM19=-1.                                                          
      CALL STATS                                                        
C                                                                       
C  ============   E N D    O F    S I M U L A T I O N  =================
C                                                                       
      CALL CPUTIM (CPU1)                                                
      CALL ELAPSE (WAL1)                                                
      WRITE (6,1234) CPU1-CPU0,MOD(WAL1-WAL0+1000000.0,1000000.0)       
      WRITE (8,1234) CPU1-CPU0,MOD(WAL1-WAL0+1000000.0,1000000.0)       
C                                                                       
      WRITE(1,*)                                                        
      WRITE(1,*) 'ELAPSED CPU TIME IN SECONDS: ',CPU1-CPU0              
C MFLOPS = (CRAY MFLOP)/CPU                                             
      WRITE(1,*) 'MFLOPS: ',503.8054/(CPU1-CPU0)                        
      WRITE(1,*) 'ELAPSED WALLCLOCK TIME IN SECONDS: ',                 
     *            MOD(WAL1-WAL0+1000000.0,1000000.0)                    
1234  FORMAT (' TOTAL TIME USED IN THIS JOB:',/,                        
     1        ' CPU TIME  = ',F15.3,' SECONDS.',/,                      
     2        ' WALL TIME = ',F15.3,' SECONDS.',/)                      
CX70000 CALL CNTOTX ()                                                  
CY70000 CALL CNTOTY ()                                                  
CX50000 CALL MAINOX ()                                                  
CY50000 CALL MAINOY ()                                                  
      STOP                                                              
      END                                                               
                                                                        
C                                                                       
C  *********************************************************************
C  *   SUBROUTINE TO SET THE ARRAY POINTERS FOR VECTORIZING THE CODE.  *
C  *********************************************************************
C                                                                       
      SUBROUTINE PSET(NX,NY,NZ,NT,NTIME,NWINDX,NWINDY,NSINKS,NFILT,     
     *XSTART,YSTART,ZSTART,TSTART,DELTAX,DELTAY,DELTAZ,DELTAT,PHI,DL,   
     *DX,DY,DZ,WORK,IB,IK,ITY,NCOUNT,NPRINT,NGRAPH,NPSTEP,NGSTEP)       
      DIMENSION  WORK(*)                                                
      CHARACTER DUMMY                                                   
      COMMON/LAKE/SX,SIGX,SY,SIGY,ZNOT,SFX,SFY,FLX,FLY,BASE,TSL,H0,ZW,ZL
      COMMON/SOURCE/INIT(2,2),NSOUR(2),IX(2,2),JY(2,2),KZ(2,2),         
     * IVAL(2,2),NSX(2,2),NSY(2,2),NSZ(2,2),ISR(2,2)                    
      COMMON/LEVEL/KK1,KK2,KK3,KK4,IYHOM,IGEO,IUGX,IVGY,LT0,LT1,ICPU    
      COMMON/STRCH/ALP,BET,DH,ZH,UG,VG,T1,T2,DT,TOL,ALPHA,HAMP,BUMP     
      COMMON/CPU/CINIT,CINHC,CINVC,CINHT,CINVT,CINPI,CINHU,CINVU,       
     *CINHV,CINVV,CINHW,CINVW,CINPR,CINBL,CINFL,CINMN,TM1,TM18,TM19     
CX30003 CALL SBINX (3)                                                  
CY30003 CALL SBINY (3)                                                  
C                                                                       
C **   SEPARATE DIMENSIONALITY OF PROGRAM                               
C                                                                       
      L3=NX*NY*NZ                                                       
      L2=NX*NY                                                          
      L1=NZ                                                             
C                                                                       
C ===== ALLOCATION OF GLOBAL MEMORY FOR PARAMETERS IN VECTOR FORM  =====
C                                                                       
C **   MESO-CONCENTRATION OF ONE POLLUTANT C(X,Y,Z,T)                 **
      LC=1                                                              
      LAST=L3                                                           
C **   PREVIOUS STEPS OF C(X,Y,Z,T-1) FOR THE TIME SCHEME             **
      LCSTEP=LAST+1                                                     
      LAST=LAST+L3                                                      
C **   MESO-PERTURBATION POTENTIAL TEMPERATURE POTT(X,Y,Z,T)          **
      LPOT=LAST+1                                                       
      LAST=LAST+L3                                                      
C **   PREVIOUS STEPS OF POTT(X,Y,Z,T-1) FOR THE TIME SCHEME          **
      LTSTEP=LAST+1                                                     
      LAST=LAST+L3                                                      
C **   MESO-PERTURBATION U - WIND COMPONENT UX(X,Y,Z,T)               **
      LUX=LAST+1                                                        
      LAST=LAST+L3                                                      
C **   PREVIOUS STEPS OF UX(X,Y,Z,T-1) FOR THE TIME SCHEME            **
      LUSTEP=LAST+1                                                     
      LAST=LAST+L3                                                      
C **   MESO-PERTURBATION V - WIND COMPONENT VY(X,Y,Z,T)               **
      LVY=LAST+1                                                        
      LAST=LAST+L3                                                      
C **   PREVIOUS STEPS OF VY(X,Y,Z,T-1) FOR THE TIME SCHEME            **
      LVSTEP=LAST+1                                                     
      LAST=LAST+L3                                                      
C **   MESO-PERTURBATION W - WIND COMPONENT WZ(X,Y,Z,T)               **
      LWZ=LAST+1                                                        
      LAST=LAST+L3                                                      
C **   MESO-PERTURBATION PRESSURE PI PRESS(X,Y,Z,T)                   **
      LPI=LAST+1                                                        
      LAST=LAST+L3                                                      
C **   PREVIOUS STEP OF PRESSURE PI PRESS(X,Y,Z,T)                    **
      LPSTEP=LAST+1                                                     
      LAST=LAST+L3                                                      
C **   SOURCES OR SINKS FOR THE POLLUTANTS  C,  Q(X,Y,Z)              **
      LQ=LAST+1                                                         
      LAST=LAST+L3                                                      
C **   DIFFUSSIVITY COEFFICIENT FOR MOMENTUM DKZ(X,Y,Z)=DKZM(X,Y,Z)   **
      LDKZM=LAST+1                                                      
      LAST=LAST+L3                                                      
C **   DIFFUSSIVITY COEFFICIENT FOR HEAT DKZ(X,Y,Z)=DKZH(X,Y,Z)       **
      LDKZH=LAST+1                                                      
      LAST=LAST+L3                                                      
C **   TERRAIN ELEVATION IN METERS ELEV(X,Y)                          **
      LELEV=LAST+1                                                      
      LAST=LAST+L2                                                      
C **   TERRAIN X-GRADIENT IN METERS ELEVX(X,Y)                        **
      LELEVX=LAST+1                                                     
      LAST=LAST+L2                                                      
C **   TERRAIN Y-GRADIENT IN METERS ELEVY(X,Y)                        **
      LELEVY=LAST+1                                                     
      LAST=LAST+L2                                                      
C **   ROUGHNESS LENGTH OF TERRAIN IN METERS Z0(X,Y)                  **
      LZ0=LAST+1                                                        
      LAST=LAST+L2                                                      
C **   MIXING HEIGHT OR BOUNDARY LAYER HEIGHT HMIX(X,Y)               **
      LHMIX=LAST+1                                                      
      LAST=LAST+L2                                                      
C **   MIXING HEIGHT AT THE PREVIOUS TIME STEP STEPH(X,Y)             **
      LSTEPH=LAST+1                                                     
      LAST=LAST+L2                                                      
C **   MEAN TEMPERATURE IN THE SURFACE LAYER TAVR(X,Y)                **
      LTAVR=LAST+1                                                      
      LAST=LAST+L2                                                      
C **   MONIN-OBUKHOV LENGTH OBUK(X,Y)                                 **
      LOBUK=LAST+1                                                      
      LAST=LAST+L2                                                      
C **   FRICTION VELOCITY USTAR USTR(X,Y)                              **
      LUSTR=LAST+1                                                      
      LAST=LAST+L2                                                      
C **   TURBULENT  TEMPERATURE THETASTAR TSTR(X,Y)                     **
      LTSTR=LAST+1                                                      
      LAST=LAST+L2                                                      
C **   DRY DEPOSITION VELOCITY VDEP(X,Y)                              **
      LVDEP=LAST+1                                                      
      LAST=LAST+L2                                                      
C **   SURFACE DEPOSITION OF  POLLUTANTS  DEP(X,Y)                    **
      LDEP=LAST+1                                                       
      LAST=LAST+L2                                                      
C **   VERTICAL HEIGHT Z  ZET(Z)                                      **
      LZET=LAST+1                                                       
      LAST=LAST+L1                                                      
C **   UNEQUAL POINT STRECHED PARAMETER  DH/DZ = HVAR(Z)              **
      LHVAR=LAST+1                                                      
      LAST=LAST+L1                                                      
C **   MEAN OR SYNOPTIC U-WIND COMPONENT  UM(Z)                       **
      LUM=LAST+1                                                        
      LAST=LAST+L1                                                      
C **   MEAN OR SYNOPTIC V-WIND COMPONENT  VM(Z)                       **
      LVM=LAST+1                                                        
      LAST=LAST+L1                                                      
C **   GEOSTROPHIC U-WIND COMPONENT  UG(Z)                            **
      LUG=LAST+1                                                        
      LAST=LAST+L1                                                      
C **   GEOSTROPHIC V-WIND COMPONENT  VG(Z)                            **
      LVG=LAST+1                                                        
      LAST=LAST+L1                                                      
C **   MEAN OR SYNOPTIC POTENTIAL TEMPERATURE TM(Z)                   **
      LTM=LAST+1                                                        
      LAST=LAST+L1                                                      
C **   MEAN OR SYNOPTIC EDDY DIFFUSSIVITY DKM(Z)                      **
      LKM=LAST+1                                                        
      LAST=LAST+L1                                                      
C                                                                       
C  =====       ALLOCATION OF AUXILIARY WORK SPACE     ==================
C                                                                       
C **   DERIVATIVES WITH RESPECT TO X  DCDX(X,Y,Z)                     **
      LDCDX=LAST+1                                                      
      LAST=LAST+L3                                                      
C **   DERIVATIVES WITH RESPECT TO Y  DCDY(X,Y,Z)                     **
      LDCDY=LAST+1                                                      
      LAST=LAST+L3                                                      
C **   HELP VECTOR FOR PADE SCHEME -CENTER ELEMENTS-                  **
      LAN=LAST+1                                                        
      LAST=LAST+L1                                                      
C **   HELP VECTOR FOR PADE SCHEME -LEFT   ELEMENTS-                  **
      LBN=LAST+1                                                        
      LAST=LAST+L1                                                      
C **   HELP VECTOR FOR PADE SCHEME -RIGHT  ELEMENTS-                  **
      LCN=LAST+1                                                        
      LAST=LAST+L1                                                      
C **   UTILITY VECTOR FOR NUMERICAL WORK                              **
      LHELP=LAST+1                                                      
      LAST=LAST+MAX(NX,NY,NZ)                                           
C **   ANOTHER UTILITY VECTOR FOR DIRTY WORK                          **
      LHELPA=LAST+1                                                     
      LAST=LAST+MAX(NX,NY,NZ)                                           
C **    WORK VECTOR FOR THE X-FFT                                     **
      LSAVEX=LAST+1                                                     
      LAST=LAST+2*NX+15                                                 
C **    WORK VECTOR FOR THE Y-FFT                                     **
      LSAVEY=LAST+1                                                     
      LAST=LAST+2*NY+15                                                 
C **    X-WAVENUMBERS  FOR FIRST DERIVATIVES                          **
      LFX=LAST+1                                                        
      LAST=LAST+NX*0.5                                                  
C **    X- WEIGHTS FOR HEAT AND POLLUTANTS X,Y SPECTRAL DIFFUSION     **
      LFXC=LAST+1                                                       
      LAST=LAST+NX                                                      
C **    X - WEIGHTS FOR MOMENTUM HORIZONTAL SPECTRAL DIFFUSION        **
      LFXX=LAST+1                                                       
      LAST=LAST+NX*0.5                                                  
C **    Y-WAVENUMBERS FOR FIRST DERIVATIVES                           **
      LFY=LAST+1                                                        
      LAST=LAST+NY*0.5                                                  
C **    Y- WEIGHTS FOR HEAT AND POLLUTANTS X,Y SPECTRAL DIFFUSION     **
      LFYC=LAST+1                                                       
      LAST=LAST+NY                                                      
C **    Y - WEIGHTS FOR MOMENTUM HORIZONTAL SPECTRAL DIFFUSION        **
      LFYY=LAST+1                                                       
      LAST=LAST+NY*0.5                                                  
C **    X - FILTER FOR DERIVATIVE  DIFFUSION                          **
      LFILX=LAST+1                                                      
      LAST=LAST+NX                                                      
C **    Y - FILTER FOR DERIVATIVE  DIFFUSION                          **
      LFILY=LAST+1                                                      
      LAST=LAST+NY                                                      
C **    Z - FILTER FOR THE SPONGE LAYER IN Z                          **
      LFILZ=LAST+1                                                      
      LAST=LAST+NZ                                                      
C                                                                       
C     MAKE A LAST CHECK                                                 
C                                                                       
      WRITE(6,'(A,I8,A)') ' WORK ARRAY HAS ',LAST,                      
     1' ELEMENTS.  '                                                    
      IF(NWINDX.EQ.1) PAUSE                                             
C                                                                       
C                                                                       
C   ====================================================================
C   *   THIS SUBROUTINE RUN DOES ALL CALCULATIONS  AND ALLOCATES       *
C   *   GLOBAL TO STATIC MEMORY FOR VECTOR OPERATIONS                  *
C   ====================================================================
C                                                                       
C                                                                       
      CALL RUN(NX,NY,NZ,NT,NTIME,NWINDX,NWINDY,NSINKS,NFILT,XSTART,     
     * YSTART,ZSTART,TSTART,DELTAX,DELTAY,DELTAZ,DELTAT,PHI,DL,         
     * DX,DY,DZ,IB,IK,ITY,NCOUNT,NPRINT,NGRAPH,NPSTEP,NGSTEP,LAST,      
     * WORK(LC),WORK(LCSTEP),WORK(LPOT),WORK(LTSTEP),WORK(LUX),         
     * WORK(LUSTEP),WORK(LVY),WORK(LVSTEP),WORK(LWZ),WORK(LPI),         
     * WORK(LPSTEP),WORK(LQ),WORK(LDKZM),WORK(LDKZH),WORK(LELEV),       
     * WORK(LELEVX),WORK(LELEVY),WORK(LZ0),WORK(LHMIX),WORK(LSTEPH),    
     * WORK(LTAVR),WORK(LOBUK),WORK(LUSTR),WORK(LTSTR),WORK(LVDEP),     
     * WORK(LDEP),WORK(LZET),WORK(LHVAR),WORK(LUM),WORK(LVM),WORK(LUG), 
     * WORK(LVG),WORK(LTM),WORK(LKM),WORK(LDCDX),WORK(LDCDY),WORK(LAN), 
     * WORK(LBN),WORK(LCN),WORK(LHELP),WORK(LHELPA),WORK(LSAVEX),       
     * WORK(LSAVEY),WORK(LFX),WORK(LFXC),WORK(LFXX), WORK(LFY),         
     * WORK(LFYC),WORK(LFYY), WORK(LFILX),WORK(LFILY),WORK(LFILZ))      
CX40004 CALL SBOUTX (4)                                                 
CY40004 CALL SBOUTY (4)                                                 
C                                                                       
      RETURN                                                            
      END                                                               
C                                                                       
C                                                                       
C  THIS SUBROUTINE IS CALLED BY   PSET.   IT CALLS OTHER SUB-           
C  ROUTINES AND CALCULATES THE RIGHT-HAND SIDE OF THE DISCRETIZED       
C  SYSTEM.                                                              
C                                                                       
C                                                                       
      SUBROUTINE RUN(NX,NY,NZ,NT,NTIME,NWINDX,ISH,NSMT,NFILT,           
     * XSTART,YSTART,ZSTART,TSTART,DELTAX,DELTAY,DELTAZ,DELTAT,PHI,DL,  
     * DX,DY,DZ,IB,IK,ITY,NCOUNT,NPRINT,NGRAPH,NPSTEP,NGSTEP,LFINAL,    
     * C,STEPC,POTT,STEPT,UX,STEPU,VY,STEPV,WZ,PRES,STEPP,Q,DKZM,DKZH,  
     * ELEV,ELEVX,ELEVY,Z0,HMIX,STEPH,TAVR,OBUK,USTR,TSTR,VDEP,DEP,     
     * ZET,HVAR,UM,VM,UG,VG,TM,DKM,DCDX,DCDY,AN,BN,CN,HELP,HELPA,       
     * SAVEX,SAVEY,FX,FXC,FXX,FY,FYC,FYY,FILX,FILY,FILZ)                
C                                                                       
C       VARIABLE DECLARATIONS                                           
C                                                                       
      DIMENSION  C(*),STEPC(*),POTT(*),STEPT(*),UX(*),STEPU(*),         
     * VY(*),STEPV(*),WZ(*),PRES(*),STEPP(*),Q(*),DKZM(*),DKZH(*),      
     * ELEV(*),ELEVX(*),ELEVY(*),Z0(*),HMIX(*),STEPH(*),TAVR(*),        
     * OBUK(*),USTR(*),TSTR(*),VDEP(*), DEP(*),ZET(*),HVAR(*),          
     * UM(*),VM(*),UG(*),VG(*),TM(*),DKM(*), DCDX(*),DCDY(*),           
     * AN(*),BN(*),CN(*),HELP(*),HELPA(*), SAVEX(*),SAVEY(*),           
     * FX(*),FXC(*),FXX(*),FY(*),FYC(*),FYY(*),FILX(*),FILY(*),FILZ(*)  
C                                                                       
      COMMON/STRCH/ALP,BET,DH,ZH,UGH,VGH,T1,T2,DT,TOL,ALPHA,HAMP,BUMP   
      COMMON/SOURCE/INIT(2,2),NSOUR(2),IX(2,2),JY(2,2),KZ(2,2),         
     *IVAL(2,2),NSX(2,2),NSY(2,2),NSZ(2,2),ISR(2,2)                     
      COMMON/LEVEL/KK1,KK2,KK3,KK4,IYHOM,IGEO,IUGX,IVGY,LT0,LT1,ICPU    
      COMMON/LAKE/SX,SIGX,SY,SIGY,ZNOT,SFX,SFY,FLX,FLY,BASE,TSL,H0,ZW,ZL
      COMMON/CPU/CINIT,CINHC,CINVC,CINHT,CINVT,CINPI,CINHU,CINVU,       
     *CINHV,CINVV,CINHW,CINVW,CINPR,CINBL,CINFL,CINMN,TM1,TM18,TM19     
CX30005 CALL SBINX (5)                                                  
CY30005 CALL SBINY (5)                                                  
C                                                                       
C   ********************************************************************
C   *   CALCULATE SOME CONSTANTS AND INITIALIZE SOME LOCAL VARIABLES.  *
C   *    LOOP: NUMBER OF POINTS TO LOOP FOR TIME INTEGRATION           *
C   *    H= REGULAR TIME STEP, H1=FINER TIME STEP, NCOUNT=NUMBER OF    *
C   *    FINER TIME STEPS, TEND= END OF TIME INTEGRATION, NX1,NY1 ARE  *
C   *    HALF POINTS FOR PSEUDOSPECTRAL COLLOCATIONS                   *
C   ********************************************************************
C                                                                       
C    ADDITIONAL ALLOCATION OF VECTOR SPACE INDICES                      
C                                                                       
      NX1=NX/2                                                          
      NY1=NY/2                                                          
      NXNY=NX*NY                                                        
      NXNY1=1-NXNY                                                      
      LOOP=NX*NY*NZ                                                     
      LENGTH=MAX(NX,NY,NZ)                                              
C     ====================   VECTOR # 1  ===============================
      LV1=1                                                             
      LAST=LENGTH                                                       
C     ====================   VECTOR # 2  ===============================
      LV2=LAST+1                                                        
      LAST=LV2+LENGTH                                                   
C     ====================   VECTOR # 3  ===============================
      LV3=LAST+1                                                        
      LAST=LV3+LENGTH                                                   
C     ====================   VECTOR # 4  ===============================
      LV4=LAST+1                                                        
      LAST=LV4+LENGTH                                                   
C     ====================   VECTOR # 5  ===============================
      LV5=LAST+1                                                        
      LAST=LV5+LENGTH                                                   
C     ====================   VECTOR # 6  ===============================
      LV6=LAST+1                                                        
      LAST=LV6+LENGTH                                                   
C     ====================   VECTOR # 7  ===============================
      LV7=LAST+1                                                        
      LAST=LV7+LENGTH                                                   
C                                                                       
C     SUPRESS UNDERFLOW ERRORS IN THE PROGRAM                           
C     A T T E N T I O N ] ] ]    O N L Y    O N     T H E     V M       
C                                                                       
C     CALL XUFLOW                                                       
C                                                                       
C     AT THE TOP LEVEL OF THE MODEL C,POTT,UX,VY,WZ,PRES ARE ZERO       
C     AND THEREFORE ARE NOT CALCULATED. AT THE BOTTOM ONLY UX,          
C     UY, AND WZ ARE ZERO                                               
C                                                                       
      NZTOP=NZ-1                                                        
      LOOP=NX*NY*NZTOP                                                  
      PI=ATAN(1.0)*4.0                                                  
      OMEGA=7.292E-5                                                    
      F=2.*OMEGA*SIN(PI*PHI/180.)                                       
      FHAT=2.*OMEGA*COS(PI*PHI/180.)                                    
C                                                                       
C     DAYLIGHT AS EXPRESSED BY STANDAR DEVIATION IN GAUSSIAN FORCING    
C                                                                       
      DAY=43200.00                                                      
      DAYL=DAY/2.4495                                                   
C                                                                       
C     JUMP TO A REAL RUN IF CONTINUING AN INTERRUPTED RUN               
C                                                                       
      IF(NPRINT.EQ.1) GOTO 10                                           
C                                                                       
C     INITIALIZE TEST PARAMETERS AND CPU COUNTERS                       
C                                                                       
      CINIT=0.0                                                         
      CINHC=0.0                                                         
      CINVC=0.0                                                         
      CINHT=0.0                                                         
      CINVT=0.0                                                         
      CINPI=0.0                                                         
      CINHU=0.0                                                         
      CINVU=0.0                                                         
      CINHV=0.0                                                         
      CINVV=0.0                                                         
      CINHW=0.0                                                         
      CINVW=0.0                                                         
      CINPR=0.0                                                         
      CINBL=0.0                                                         
      CINFL=0.0                                                         
      CINMN=0.0                                                         
      TM10=0.0                                                          
      CMASS=0.0                                                         
      HEAT=0.0                                                          
      EXNER=0.0                                                         
      UWIND=0.0                                                         
      USQ=0.0                                                           
      VWIND=0.0                                                         
      VSQ=0.0                                                           
      WWIND=0.0                                                         
      WSQ=0.0                                                           
      NSTEP=0                                                           
      TOUT=0.0                                                          
      TIME1=TSTART                                                      
      TEND1=TSTART+NT*DELTAT                                            
      IF(NY.GT.1) IYHOM=1                                               
C                                                                       
C       SET THE INITIAL CONDITIONS FOR C                                
C                   AND ALSO                                            
C       ESTABLISH THE SOURCES OR SINKS IN THE DOMAIN                    
C                                                                       
      CALL SETALL(NX,NY,NZ,XSTART,YSTART,ZSTART,                        
     *DELTAX,DELTAY,DELTAZ,C,Q,CMASS)                                   
C                                                                       
C       SET THE VERTICAL VARIABLE (EQUAL OR LOGARITHMIC ENCREMENTS)     
C                                                                       
      CALL STRECH(FILZ,HVAR,ZET,NZ,DELTAZ,NP,ITY)                       
C                                                                       
C                                                                       
C     CALCULATE THE MEAN WIND COMPONENTS WITH MODIFIED EKMAN THEORY     
C        DZM IS THE DIFFUSSIVITY COEFFICIENT OBTAINED THROUGH           
C        THE EKMAN THEORY, WHILE DZ IS PRESET FROM DATA.                
C                                                                       
      CALL UVSET(NX,NY,NZ,HVAR,ZET,NP,DZ,DKM,UM,VM,UG,VG,TM,DCDX,       
     *ITY,ISH,NSMT,F)                                                   
C                                                                       
C       CALCULATE HORIZONTAL DIFFUSION COEFFICIENTS FOR THE FFT'S       
C                                                                       
      CALL HORDFC(NX,NX1,XSTART,DELTAX,PI,DELTAT,DX,FX,FXC,FXX,         
     *SAVEX,NTIME)                                                      
      IF(NY.GT.1)                                                       
     *CALL HORDFC(NY,NY1,YSTART,DELTAY,PI,DELTAT,DY,FY,FYC,FYY,         
     *SAVEY,NTIME)                                                      
C                                                                       
C      SET THE TOPOGRAPHY MATRIX, AND GRADIENTS OF TOPOGRAPHY.          
C                                      =-0.1       WATER                
C       FOR  EVERY I,J: IF   ELEV(I,J) = 0.0  50% WATER, 50% LAND       
C                                      > 0.0       LAND                 
C      ALSO SET THE SURFACE ROUGHNESS ACCORDING TO TOPOGRAPHY           
C                                                                       
      CALL TOPO(NX,NY,XSTART,YSTART,DELTAX,DELTAY,ELEV,ELEVX,ELEVY,Z0,  
     *HELP,HELPA,NX1,FX,FXX,FILX,SAVEX,NY1,FY,FYY,FILY,SAVEY)           
C                                                                       
C     SET THE INITIAL HEIGHT OF THE PLANETARY BOUNDARY LAYER IN X,Y     
C                                                                       
      CALL INITBL(NX,NY,ELEV,HMIX,H0)                                   
C                                                                       
C      FIND THE INITIAL EDDY DIFFUSSIVITIY COEFFICIENTS                 
C                                                                       
      CALL DKZMH(HELP,HELPA,TM,UM,VM,POTT,UX,VY,WZ,ZET,DKZM,DKZH,DZ,    
     *Z0,ELEV,NX,NX1,NY,NY1,NZ,HMIX,STEPH,TAVR,OBUK,USTR,TSTR,VDEP,     
     *0,F,NFILT,-1,DELTAT,SAVEX,SAVEY,FX,FY,FXC,FYC,DCDX,DCDY,TSL,DL)   
C                                                                       
C      PRINT INITIAL RESULTS                                            
C                                                                       
      CALL PRINTR(NX,NY,NZ,NT,XSTART,YSTART,ZSTART,TSTART,DX,DY,DZ,     
     *DELTAX,DELTAY,DELTAZ,DELTAT,TIME1,TOUT,1,C,UM,UX,VM,VY,TM,        
     *POTT,WZ,PRES,DKM,DKZM,DKZH,DEP,NPRINT,NGRAPH,NPSTEP,NGSTEP,NSTEP, 
     *IBT,NWINDX,ISH,NSMT,NFILT,IB,IK,ITY,NCOUNT,Z0,ELEV,HMIX,TAVR,OBUK,
     *USTR,TSTR,VDEP,PHI,CMASS,UWIND,USQ,VWIND,VSQ,WWIND,WSQ,HEAT,EXNER)
C                                                                       
      CALL CPUCLK(TM2,1,BIAS)                                           
      CINIT=TM2-TM1                                                     
C                                                                       
C ======================================================================
C ==     *********      START THE TIME INTEGRATION    **********      ==
C ======================================================================
C                                                                       
 10   CONTINUE                                                          
CX10805 CALL DOINX( 805 )
CY10805 CALL DOINY( 805 )
      NSTEP=NSTEP+1                                                     
C                                                                       
C     USE ISTEP TO DESIDE WHEN THE EULER SCHEME SHOULD BE USED          
C     TO SUPPRESS THE ODD-EVEN COMPUTATIONAL MODE FROM LEAPFROG SCHEME  
C                                                                       
      ISTEP=NSTEP                                                       
      IF(MOD(NSTEP,NCOUNT).EQ.0) ISTEP=1                                
C                                                                       
C ----   CORRECT THE HORIZONTAL BOUNDARY CONDITIONS FOR C(X,Y,Z) -------
C                                                                       
C      CALL HORBC(NX,NY,NZ,NT,XSTART,YSTART,ZSTART,TSTART,              
C     *DELTAX,DELTAY,DELTAZ,DELTAT,TIME1,UX,VY,C,Q)                     
C                                                                       
C  *********************************************************************
C                                                                       
C            THE  SOLUTION  OF THE COMPLETE SYSTEM IS PERFORMED BY USING
C       THE SPLITTING-UP METHOD.  IN SPECIFIC THE  HORIZONTAL  ADVECTION
C       IS  CARRIED  OUT  BY AN EXPLICIT LEAPFROG SCHEME, THE HORIZONTAL
C       DIFFUSION IS PERFORMED BY THE  METHOD  OF  THE  EIGENVALUES,  OR
C       EQUVALENTLY  BY VERTICAL MULTIPLYING THE FOURIER COEFFICIENTS BY
C       APPROPRIATE EXPONENTIALS.  THE  VERTICAL  DIFFUSION  IS  TREATED
C       WITH  A  SEMI-IMPLICIT  PADE-CRANK-NICKOLSON,  AS  WELL  AS  THE
C       VERTICAL ADVECTION.  THE PRESSURE DERIVATIVE TERMS  ARE  TREATED
C       WITH  THE SO-CALLED PRESSURE AVERAGING TECHNIQUE.  FINALLY OTHER
C       TERMS WILL BE DUBBED IN  THE  ADVECTION  PART  (CORIOLIS).   THE
C       MODEL  CALCULATES  PROGNOSTICALLY THE THE POTENTIAL TEMPERATURE,
C       U,V  WIND  COMPONENTS  AND  CONCENTRATIONS   OF   POLLUTANTS   C
C       (POTT,UX,VY,C).   THE PRESSURE AND THE VERTICAL VELOCITY WILL BE
C       CALCULATED DIAGNOSTICALLY (PRES,WZ).  THE DIFFUSIVITIES ARE ALSO
C       CALCULATED  DIAGNOSTICALLY  USING INFORMATION ON UX,VY, POTT THE
C       TOTAL PROCEDURE IS DONE IN THE FOLLOWING EIGHT STEPS:           
C                                                                       
C  *********************************************************************
C                                                                       
C            1)  FROM  THE  INITIAL  CONDITIONS  (U,V,THETA,  AND  THEIR
C       SYNOPTIC   COUNTERPARTS)   CALCULATE   THE   EDDY    DIFFUSIVITY
C       COEFFICIENTS  FOR  HEAT  AND  MOMENTUMED  BY  ADDING  THE  ABOVE
C       MESOSCALE PERTURBATIONS TO THEIR SYNOPTIC VALUES  AND  CALCULATE
C       ONE  KZ  WHICH  WILL  BE  THE  SUM OF THE SYNOPTIC AND MESOSCALE
C       STATE.  THEN THE MESOSCALE DIFFUSIVITIES KZ WHICH APPEAR IN  THE
C       EQUATIONS WILL BE THE DIFFERENCE OF THE (SYNOPTIC+MESO)-SYNOPTIC
C       BOUNDARY CONDITIONS FOR THE MESO+SYNOPTIC KZ ARE 0.1 M*M/SEC  AT
C       Z=0,Z=ZN.   BY-PRODUCTS OF THE CALCULATION FOR THE DIFFUSIVITIES
C       ARE THE MONIN-OBUKHOV LENGTH L, THE FRICTIONAL VELOCITY U*,  THE
C       TURBULENT  POTENTIAL  TEMPERATURE  T*,  THE  CONVECTIVE VERTICAL
C       VELOCITY SCALE W*, THE PLANETARY BOUNDARY LAYER HEIGHT H  (HMIX)
C       WHICH   IS  CALCULATED  VIA  DEARDORFFS  AND  SMEDAS  PROGNOSTIC
C       RELATION, THE DRY DEPOSITION VELOCITY VD, THE VARIABLE ROUGHNESS
C       LENGTH Z0, AND THE MEAN SURFACE LAYER TEMPERATURE.              
C                                                                       
C            2) USE THE WIND FIELDS (U,V,W) AND THE DIFFUSIVITY PROFILES
C       KZ TO ADVECT AND MIX THE  POLLUTANTS  ACCORDINGLY.   HOMOGENIOUS
C       BOUNDARY  CONTITIONS  AT THE TOP FOR C, AND REMOVAL OF C AT Z=0,
C       ACCORDING TO RATES GIVEN BY THE DRY DEPOSITION VELOCITIES VD.   
C                                                                       
C            3) SOLVE THE EQUATION FOR  THE  CONSERVATION  OF  ADIABATIC
C       ENERGY  (DT/DT) IN THE MESOSCALE.  BOUNDARY CONDITIONS OF T=0 AT
C       Z=ZN, AND T=T(X,Y,T) AT Z=0.  THE LAST  CONDITION  IS  THE  OLNY
C       INPUT OF ENERGY AT THE MODEL.                                   
C                                                                       
C            4)   HAVING   CALCULATED   T,   INTEGRATE   VERTICALLY  THE
C       HYDROSTATIC  EQUATION  TO  CALCULATE  THE  HORIZONTAL   PRESSURE
C       DISTRIBUTIONS   (PI)   FOR  EACH  VERTICAL  LAYER.   (DIAGNOSTIC
C       CALCULATION).  INTEGRATION IS PERFORMED  FROM  THE  TOP  OF  THE
C       MODEL  (ZN)  WITH  DOWNWARD  DIRECTION  UNTIL THE SURFACE OF THE
C       MODEL (Z=0)                                                     
C                                                                       
C            5) ONCE THE PRESSURE IS OBTAINED, IT IS AVERAGED  WITH  THE
C       PRESSURE  AT  THE  PREVIOUS TIME STEP, AND IT IS FILTERED AT THE
C       LATERAL BOUNDARIES.  THEN VIA FFT'S OBTAIN  ITS  GRADIENTS  WITH
C       RESPECT  TO  X,  AND  Y.  THEN THE PRESSURE STEP IN THE MOMENTUM
C       EQUATIONS IS PERFORMED IN THE VERTICAL DIRECTION.               
C                                                                       
C            6) USE THE  SYNOPTIC  PRESSURE  GRADIENT  (UG,VG)  AND  THE
C       CORIOLIS   F  TERMS  TO  SOLVE  FOR  U  AFTER  THE  GRADIENT  PI
C       PERTURBATIONS ARE ADDED.  U IS ZERO AT THE TOP AND  THE  SURFACE
C       OF THE MODEL.                                                   
C                                                                       
C            7)  USE  THE  SYNOPTIC  PRESSURE  GRADIENT  (UG,VG) AND THE
C       CORIOLIS F TERMS TO SOLVE FOR V EXACTLY AS ABOVE WITH  THE  SAME
C       BOUNDARY CONTITIONS.                                            
C                                                                       
C            8) CALCULATE THE X AND Y GRADIENDS OF THE MESOSCALE U AND V
C       PERTURBATIONS VIA FFT'S AND WITH AN  IMPLICIT  METHOD  CALCULATE
C       DIAGNOSTICALLY  THE  HORIZONTAL  DISTRIBUTIONS  OF  THE VERTICAL
C       VELOCITY, BY VERICALLY INTEGRATING THE CONTINUITY EQUATION ON  A
C       LEVEL  TO  LEVEL  BASIS.  START FROM THE BOTTOM AND MARCH UPWARD
C       ASSUMING W=0 AT THE TOP AND THE BOTTOM OF THE  MODEL.   ADD  THE
C       TOPOGRAPHY   GRADIENTS   IN  THE  CALCULATIONS  TO  ACCOUNT  FOR
C       ADDITIONAL VERTICAL MOTION AS MOMENTUM MIGHT GO UP OR  DOWN  THE
C       SLOPE OF THE MODEL'S TERRAIN.                                   
C                                                                       
C                                                                       
C **********************************************************************
C *   C O N S E R V A T I O N    O F   P O L L U T A N T   M A S S   C *
C *   T R E A T M E N T    O F   P O L L U T A N T S  C(X,Y,Z,T)=C(L)  *
C **********************************************************************
C                                                                       
C                                                                       
      CALL CPUCLK(TM2,1,BIAS)                                           
      MLAG=NXNY1                                                        
CX10507 CALL DOINX( 507 )                                               
CY10507 CALL DOINY( 507 )                                               
C                                                                       
C ----   FOR EACH Z FIND DC(X,Y,Z)/DX, DC(X,Y,Z)/DY,  VIA FFT'S  -------
C                                                                       
      DO 20 II=1,NZTOP                                                  
         MLAG=MLAG+NXNY                                                 
C                                                                       
C                  HORIZONTAL DISPERSION PART          2    2    2    2 
C ----   CALCULATE WITH  DIFFUSION EIGENVALUES THE  K D C/DX ,K D C/DY  
C                                                    X         Y        
         CALL DCTDX(NX,NY,NX1,NFILT,C(MLAG),DCDX(MLAG),HELP,HELPA,      
     *   FX,FXC,SAVEX)                                                  
         IF(NY.GT.1) CALL DCTDY(NX,NY,NY1,NFILT,C(MLAG),DCDY(MLAG),     
     *   HELP,HELPA,FY,FYC,SAVEY)                                       
 20   CONTINUE                                                          
CX20508 CALL DOOUTX( 508 )                                              
CY20508 CALL DOOUTY( 508 )                                              
C                                                                       
C      CALCULATE THE HORIZONTAL ADVECTION OF C(X,Y,Z) BY THE WINDS      
C      AND PERFORM THE HORIZONTAL TIME-INTEGRATION PART.                
C                                                                       
      CALL ADVC(NX,NY,NZTOP,ISTEP,LOOP,DELTAT,C,STEPC,UX,UM,VY,VM,      
     *Q,DCDX,DCDY)                                                      
C                                                                       
C     PERFORM THE VERTICAL INTEGRATION FOR THE CONCENTRATION C(X,Y,Z)   
C                                                                       
      CALL CPUCLK(TM3,1,BIAS)                                           
      CINHC=CINHC+TM3-TM2                                               
C                                                                       
      CALL DCDTZ(NX,NY,NZ,DELTAZ,DELTAT,DZ,IB,IK,C,Q,WZ,HVAR,VDEP,      
     *ZET,HELP,HELPA,DKM,DKZH,DCDX(LV1),DCDX(LV2),TIME1,AN,BN,CN,       
     *ITY,ISH,NSMT,DEP,CMASS)                                           
C                                                                       
      CALL CPUCLK(TM4,1,BIAS)                                           
      CINVC=CINVC+TM4-TM3                                               
C                                                                       
C **********************************************************************
C *    T H E R M O D Y N A M I C   E N E R G Y   E Q U A T I O N       *
C *    P O T E N T I A L   T E M P E R A T U R E  T(X,Y,Z,T)=POTT(L)   *
C *    S Y N O P T I C  T E M P E R A T U R E     THETA(Z) =TM(K)      *
C **********************************************************************
C                                                                       
      MLAG=NXNY1                                                        
CX10509 CALL DOINX( 509 )                                               
CY10509 CALL DOINY( 509 )                                               
C                                                                       
C ----   FOR EACH Z FIND DTHETA(X,Y,Z)/DX, DTHETA(X,Y,Z)/DY,  VIA FFT'S 
C                                                                       
      DO 30 II=1,NZTOP                                                  
         MLAG=MLAG+NXNY                                                 
C                                                                       
C        HORIZONTAL DIFFUSION         2        2     2        2         
C ----   DETERMINE THE DIFFUSION   K D THETA/DX,  K D THETA/DY          
C                                   X              Y                    
         CALL DCTDX(NX,NY,NX1,NFILT,POTT(MLAG),DCDX(MLAG),HELP,HELPA,   
     *   FX,FXC,SAVEX)                                                  
         IF(NY.GT.1) CALL DCTDY(NX,NY,NY1,NFILT,POTT(MLAG),DCDY(MLAG),  
     *   HELP,HELPA,FY,FYC,SAVEY)                                       
 30   CONTINUE                                                          
CX20510 CALL DOOUTX( 510 )                                              
CY20510 CALL DOOUTY( 510 )                                              
C                                                                       
C ---- CALCULATE THE HORIZONTAL ADVECTION OF THETA(X,Y,Z) BY THE WINDS  
C      AND PERFORM THE HORIZONTAL TIME-INTEGRATION PART.                
C                                                                       
      CALL ADVT(NX,NY,NZTOP,ISTEP,LOOP,DELTAT,POTT,STEPT,UX,UM,VY,VM,   
     *DCDX,DCDY)                                                        
C                                                                       
      CALL CPUCLK(TM5,1,BIAS)                                           
      CINHT=CINHT+TM5-TM4                                               
C                                                                       
C ----  CALCULATE THE VERTICAL ADVECTION-DIFFUSION PART OF THETA(X,Y,Z) 
C                                                                       
      CALL DTDTZ(NX,NY,NZ,DELTAZ,DELTAT,DZ,IB,IK,TM,POTT,WZ,HVAR,       
     *ZET,HELP,HELPA,DKM,DKZH,DCDX(LV1),DCDX(LV2),DCDX(LV3),            
     *DCDX(LV4),TIME1,AN,BN,CN,ITY,ISH,NSMT,ELEV,DAYL,HEAT,ISTEP)       
C                                                                       
      CALL CPUCLK(TM6,1,BIAS)                                           
      CINVT=CINVT+TM6-TM5                                               
C                                                                       
C                                                                       
C $$$$$$$$$$$$$$$  E N D    O F    T H E T A = P O T T    $$$$$$$$$$$$$$
C                                                                       
C **********************************************************************
C *    D I A G N O S T I C   H Y D R O S T A T I C   E Q U A T I O N   *
C *    T R E A T M E N T    O F   P R E S S U R E  PI(X,Y,Z,T)=PRES(L) *
C **********************************************************************
C                                                                       
C                                                                       
C      VERTICALLY INTEGRATE THE HYDROSTATIC PRESSURE                    
C                                                                       
      CALL HYD(NX,NY,NZ,PRES,STEPP,TM,POTT,ZET,HVAR,NSMT,EXNER)         
C                                                                       
      CALL CPUCLK(TM7,1,BIAS)                                           
      CINPI=CINPI+TM7-TM6                                               
C                                                                       
C $$$$$$$$$$$$$$$  E N D    O F    PI = PRESS    $$$$$$$$$$$$$$$$$$$$$$$
C                                                                       
C **********************************************************************
C *               X - M O M E N T U M  E Q U A T I O N   V I A         *
C *    U - W I N D    C O M P O N E N T   U(X,Y,Z,T)=UX(L)             *
C *    S Y N O P T I C   X - W I N D  C O M P O N E N T   U(Z) =UM(K)  *
C **********************************************************************
C                                                                       
      MLAG=NXNY1                                                        
CX10511 CALL DOINX( 511 )                                               
CY10511 CALL DOINY( 511 )                                               
C                                                                       
C ----   FOR EACH Z FIND DU(X,Y,Z)/DX, DV(X,Y,Z)/DY,  VIA FFT'S  -------
C                                                                       
      DO 40 II=1,NZTOP                                                  
         MLAG=MLAG+NXNY                                                 
C                                                                       
C        HORIZONTAL DIFFUSION         2    2     2    2                 
C ----   DETERMINE THE  DIFFUSION  K D U/DX,  K D U/DY  WITH EIGENVALUES
C                                   X          Y                        
         CALL DCTDX(NX,NY,NX1,NFILT,UX(MLAG),DCDX(MLAG),HELP,HELPA,     
     *   FX,FXX,SAVEX)                                                  
         IF(NY.GT.1) CALL DCTDY(NX,NY,NY1,NFILT,UX(MLAG),DCDY(MLAG),    
     *   HELP,HELPA,FY,FYY,SAVEY)                                       
 40   CONTINUE                                                          
CX20512 CALL DOOUTX( 512 )                                              
CY20512 CALL DOOUTY( 512 )                                              
C                                                                       
C            CALCULATE THE HORIZONTAL ADVECTION OF U(X,Y,Z) BY THE WINDS
C       AND  PERFORM  THE  HORIZONTAL   TIME-INTEGRATION   PART.    ALSO
C       CALCULATE  CONTRIBUTIONS  DUE  TO  THE  HORIZONTAL  AND VERTICAL
C       CORIOLIS COMPONENTS AS WELL  AS  EFFECTS  OF  SYNOPTIC  PRESSURE
C       GRADIENT THROUGH GEOSTROPHIC WINDS                              
C                                                                       
      CALL ADVU(NX,NY,NZTOP,ISTEP,LOOP,DELTAT,STEPT,UX,STEPU,UM,VY,VM,  
     *WZ,VG,TM,F,FHAT,DCDX,DCDY)                                        
C                                                                       
C      CALCULATE THE HORIZONTAL X-PRESSURE GRADIENT WITH PSEUDOSPECTRAL 
C      TRANSFORMS AND PUT IT ON THE DCDX VECTOR                         
C                                                                       
      MLAG=NXNY1                                                        
CX10513 CALL DOINX( 513 )                                               
CY10513 CALL DOINY( 513 )                                               
      DO 50 II=1,NZTOP                                                  
         MLAG=MLAG+NXNY                                                 
         CALL DPDX(NX,NY,NX1,NFILT,PRES(MLAG),STEPP(MLAG),DCDX(MLAG),   
     *   HELP,HELPA,FX,FXC,FILX,SAVEX)                                  
 50   CONTINUE                                                          
CX20514 CALL DOOUTX( 514 )                                              
CY20514 CALL DOOUTY( 514 )                                              
C                                                                       
      CALL CPUCLK(TM8,1,BIAS)                                           
      CINHU=CINHU+TM8-TM7                                               
C                                                                       
C                                                                       
C ----  CALCULATE THE VERTICAL ADVECTION-DIFFUSION PART OF U(X,Y,Z) ----
C                                                                       
      CALL DUDTZ(NX,NY,NZ,DELTAZ,DELTAT,DZ,IB,IK,UM,UX,WZ,HVAR,         
     *ZET,HELP,HELPA,DKM,DKZM,DCDY(LV1),DCDY(LV2),DCDY(LV3),            
     *DCDY(LV4),DCDX,TIME1,AN,BN,CN,ITY,ISH,NSMT,TM,                    
     *UWIND,USQ,ISTEP)                                                  
C                                                                       
      CALL CPUCLK(TM9,1,BIAS)                                           
      CINVU=CINVU+TM9-TM8                                               
      TM10=TM9                                                          
C                                                                       
C $$$$$$$$$$$$$$$  E N D    O F    U = UX  $$$$$$$$$$$$$$$$$$$$$$$$$$$$$
C                                                                       
      IF(IYHOM.EQ.0) GOTO 90                                            
C                                                                       
C **********************************************************************
C *               Y - M O M E N T U M  E Q U A T I O N   V I A         *
C *    V - W I N D    C O M P O N E N T   V(X,Y,Z,T)=VX(L)             *
C *    S Y N O P T I C   Y - W I N D  C O M P O N E N T   V(Z) =VM(K)  *
C **********************************************************************
C                                                                       
      MLAG=NXNY1                                                        
CX10515 CALL DOINX( 515 )                                               
CY10515 CALL DOINY( 515 )                                               
C                                                                       
C ----   FOR EACH Z FIND DV(X,Y,Z)/DX, DV(X,Y,Z)/DY,  VIA FFT'S  -------
C                                                                       
      DO 60 II=1,NZTOP                                                  
         MLAG=MLAG+NXNY                                                 
C                           2    2     2    2                           
C ----   DETERMINE THE   K D V/DX,  K D V/DY  WITH DIFFUSION EIGENVALUES
C                         X          Y                                  
         CALL DCTDX(NX,NY,NX1,NFILT,VY(MLAG),DCDX(MLAG),HELP,HELPA,     
     *   FX,FXX,SAVEX)                                                  
         IF(NY.GT.1) CALL DCTDY(NX,NY,NY1,NFILT,VY(MLAG),DCDY(MLAG),    
     *   HELP,HELPA,FY,FYY,SAVEY)                                       
 60   CONTINUE                                                          
CX20516 CALL DOOUTX( 516 )                                              
CY20516 CALL DOOUTY( 516 )                                              
C                                                                       
C            CALCULATE THE HORIZONTAL ADVECTION OF V(X,Y,Z) BY THE WINDS
C       AND  PERFORM  THE  HORIZONTAL   TIME-INTEGRATION   PART.    ALSO
C       CALCULATE   CONTRIBUTIONS   DUE   TO   THE  HORIZONTAL  CORIOLIS
C       COMPONENTS AS WELL AS  EFFECTS  OF  SYNOPTIC  PRESSURE  GRADIENT
C       THROUGH GEOSTROPHIC WINDS                                       
C                                                                       
      CALL ADVV(NX,NY,NZTOP,ISTEP,LOOP,DELTAT,STEPT,STEPU,UM,VY,STEPV,  
     *VM,UG,TM,F,DCDX,DCDY)                                             
C                                                                       
C      CALCULATE THE HORIZONTAL Y-PRESSURE GRADIENT WITH PSEUSOSPECTRAL 
C      TRANSFORMS AND PUT IT ON THE DCDY VECTOR ONLY IF NY>1            
C                                                                       
      IF(NY.EQ.1) GOTO 80                                               
C                                                                       
      MLAG=NXNY1                                                        
CX10517 CALL DOINX( 517 )                                               
CY10517 CALL DOINY( 517 )                                               
      DO 70 II=1,NZTOP                                                  
         MLAG=MLAG+NXNY                                                 
         CALL DPDY(NX,NY,NY1,NFILT,PRES(MLAG),STEPP(MLAG),DCDY(MLAG),   
     *   HELP,HELPA,FY,FYC,FILY,SAVEY)                                  
 70   CONTINUE                                                          
CX20518 CALL DOOUTX( 518 )                                              
CY20518 CALL DOOUTY( 518 )                                              
C                                                                       
C ----  CALCULATE THE VERTICAL ADVECTION-DIFFUSION PART OF V(X,Y,Z) ----
C                                                                       
 80   CONTINUE                                                          
C                                                                       
      CALL CPUCLK(TM10,1,BIAS)                                          
      CINHV=CINHV+TM10-TM9                                              
C                                                                       
      CALL DVDTZ(NX,NY,NZ,DELTAZ,DELTAT,DZ,IB,IK,VM,VY,WZ,HVAR,         
     *ZET,HELP,HELPA,DKM,DKZM,DCDX(LV1),DCDX(LV2),DCDX(LV3),            
     *DCDX(LV4),DCDY,TIME1,AN,BN,CN,ITY,ISH,NSMT,TM,                    
     *VWIND,VSQ,ISTEP)                                                  
C                                                                       
C $$$$$$$$$$$$$$$$$$$  E N D    O F    V = VY  $$$$$$$$$$$$$$$$$$$$$$$$$
C                                                                       
 90   CONTINUE                                                          
C                                                                       
      CALL CPUCLK(TM11,1,BIAS)                                          
      CINVV=CINVV+TM11-TM10                                             
C                                                                       
C **********************************************************************
C *    D I A D N O S T I C   C O N T I N U I T Y     E Q U A T I O N   *
C *    F O R   T H E  V E R T I C A L  V E L O C I T Y W(X,Y,Z,T)=WZ(L)*
C **********************************************************************
C                                                                       
C                                                                       
C      VERTICALLY INTEGRATE THE  SUM OF  U(X,Y,Z) AND V(X,Y,Z)          
C      FIRST FIND THE GRADIENTS OF U,V VIA FFT'S                        
C                                                                       
      MLAG=NXNY1                                                        
CX10519 CALL DOINX( 519 )                                               
CY10519 CALL DOINY( 519 )                                               
C                                                                       
C ------  FOR EACH Z FIND DU(X,Y,Z)/DX, DV(X,Y,Z)/DY,  VIA FFT'S  ------
C                                                                       
      DO 100 II=1,NZTOP                                                 
         MLAG=MLAG+NXNY                                                 
         CALL DFTDX(NX,NY,NX1,UX(MLAG),DCDX(MLAG),HELP,FX,SAVEX)        
         IF(NY.GT.1) CALL DFTDY(NX,NY,NY1,VY(MLAG),DCDY(MLAG),          
     *   HELP,FY,SAVEY)                                                 
 100   CONTINUE                                                         
CX20520 CALL DOOUTX( 520 )                                              
CY20520 CALL DOOUTY( 520 )                                              
C                                                                       
      CALL CPUCLK(TM12,1,BIAS)                                          
      CINHW=CINHW+TM12-TM11                                             
C                                                                       
      CALL  WCONT(NX,NY,NZ,UX,VY,WZ,DCDX,DCDY,ZET,ELEVX,ELEVY,          
     *HVAR,NSMT,HELP,HELPA,AN,BN,CN,ITY,WWIND,WSQ,FILZ)                 
C                                                                       
      CALL CPUCLK(TM13,1,BIAS)                                          
      CINVW=CINVW+TM13-TM12                                             
C                                                                       
C $$$$$$$$$$$$$$$  E N D    O F    W = WZ   $$$$$$$$$$$$$$$$$$$$$$$$$$$$
C                                                                       
C                                                                       
C     TIME1 IS THE REAL TIME IN SECONDS                                 
C                                                                       
      TIME1=TIME1+DELTAT                                                
      IF(TIME1.GT.86400) TIME1=0.0                                      
C                                                                       
C ----   PRINT THE RESULTS.  ------                                     
C                                                                       
      CALL PRINTR(NX,NY,NZ,NT,XSTART,YSTART,ZSTART,TSTART,DX,DY,DZ,     
     *DELTAX,DELTAY,DELTAZ,DELTAT,TIME1,TOUT,1,C,UM,UX,VM,VY,TM,        
     *POTT,WZ,PRES,DKM,DKZM,DKZH,DEP,NPRINT,NGRAPH,NPSTEP,NGSTEP,NSTEP, 
     *IBT,NWINDX,ISH,NSMT,NFILT,IB,IK,ITY,NCOUNT,Z0,ELEV,HMIX,TAVR,OBUK,
     *USTR,TSTR,VDEP,PHI,CMASS,UWIND,USQ,VWIND,VSQ,WWIND,WSQ,HEAT,EXNER)
C                                                                       
C ----   FIND THE PERTURBATION EDDY DIFFUSSIVITY FROM BLM SOLVER -------
C                                                                       
      CALL CPUCLK(TM14,1,BIAS)                                          
      CINPR=CINPR+TM14-TM13                                             
C                                                                       
      CALL DKZMH(HELP,HELPA,TM,UM,VM,POTT,UX,VY,WZ,ZET,DKZM,DKZH,DZ,    
     *Z0,ELEV,NX,NX1,NY,NY1,NZ,HMIX,STEPH,TAVR,OBUK,USTR,TSTR,VDEP,NSMT,
     *F,NFILT,ISTEP,DELTAT,SAVEX,SAVEY,FX,FY,FXC,FYC,DCDX,DCDY,TSL,DL)  
C                                                                       
C ----   PERFORM IMPLICIT HORIZONTAL FILTERING FOR EVERY IK TIME STEPS  
C                                                                       
      CALL CPUCLK(TM15,1,BIAS)                                          
      CINBL=CINBL+TM15-TM14                                             
C                                                                       
      IF(MOD(NSTEP,IK).EQ.0) THEN                                       
         CALL SMIM(C,NX,NY,NZ,DL,DCDX(LV1),DCDX(LV2),DCDX(LV3),         
     *   DCDX(LV4),DCDX(LV5))                                           
         CALL SMIM(POTT,NX,NY,NZ,DL,DCDX(LV1),DCDX(LV2),DCDX(LV3),      
     *   DCDX(LV4),DCDX(LV5))                                           
         CALL SMIM(UX,NX,NY,NZ,DL,DCDX(LV1),DCDX(LV2),DCDX(LV3),        
     *   DCDX(LV4),DCDX(LV5))                                           
         CALL SMIM(WZ,NX,NY,NZ,DL,DCDX(LV1),DCDX(LV2),DCDX(LV3),        
     *   DCDX(LV4),DCDX(LV5))                                           
         IF(NY.GT.1.OR.IYHOM.NE.0)  CALL SMIM(VY,NX,NY,NZ,DL,           
     *   DCDX(LV1),DCDX(LV2),DCDX(LV3),DCDX(LV4),DCDX(LV5))             
      ENDIF                                                             
C                                                                       
      CALL CPUCLK(TM16,1,BIAS)                                          
      CINFL=CINFL+TM16-TM15                                             
C                                                                       
C     RECALCULATE THE MEAN POTENTIAL TEMPERATURE, GEOSTROPHIC           
C     WINDS AND SYNOPTIC WINDS IF NECESSARY. THIS IDENTIFIES            
C     SYNOPTIC CONDITIONS VARIABLE WITH TIME                            
C                                                                       
      IF(MOD(NSTEP,IGEO).EQ.0) THEN                                     
         CALL SYNSET(TIME1)                                             
         CALL UVSET(NX,NY,NZ,HVAR,ZET,NP,DZ,DKM,UM,VM,UG,VG,TM,         
     *   DCDX,ITY,ISH,NSMT,F)                                           
C                                                                       
         CALL CPUCLK(TM17,1,BIAS)                                       
         CINMN=CINMN+TM17-TM16                                          
      ENDIF                                                             
C                                                                       
C ----------------     CHECK FOR THE END OF THE TIME INTERVAL.  --------
C                                                                       
      IF(MOD(NSTEP,ICPU).EQ.0) CALL STATS                               
C      IF(TIME1.LT.TEND1) GO TO 10                                      
      IF(NSTEP.LT.NT) THEN 
CX20806 CALL DOOUTX( 806 )
CY20806 CALL DOOUTY( 806 )                                              
      GO TO 10                                          
      ELSE IF(NSTEP.EQ.NT) THEN
CX20806 CALL DOOUTX( 806 )
CY20806 CALL DOOUTY( 806 )                          
CX40006 CALL SBOUTX (6)                                                 
CY40006 CALL SBOUTY (6)                                                 
      RETURN                                                            
      ENDIF

CX40006 CALL SBOUTX (6)                                                 
CY40006 CALL SBOUTY (6)                                                 
C                                                                       
C   ====================================================================
C   ==      ************    END OF THE COMPUTATIONS.  ***********     ==
C   ====================================================================
C                                                                       
      RETURN                                                            
      END                                                               
C                                                                       
C **********************************************************************
C *   THIS ROUTINE DOES THE HORIZONTAL ADVECTION PART OF THE SOLUTION  *
C *   FOR THE CONCENTRATION OF POLLUTANTS C USING TIME SPLITTING       *
C **********************************************************************
C                                                                       
      SUBROUTINE ADVC(NX,NY,NZTOP,ISTEP,LOOP,DELTAT,C,STEPC,UX,UM,VY,VM,
     *Q,DCDX,DCDY)                                                      
C                                                                       
      REAL C(1),STEPC(1),UX(1),UM(1),VY(1),VM(1),Q(1),DCDX(1),DCDY(1)   
CX30007 CALL SBINX (7)                                                  
CY30007 CALL SBINY (7)                                                  
      L=0                                                               
      IF(NY.GT.1) THEN                                                  
CX10521 CALL DOINX( 521 )                                               
CY10521 CALL DOINY( 521 )                                               
         DO 30 K=1,NZTOP                                                
            DO 20 J=1,NY                                                
               DO 10 I=1,NX                                             
                  L=L+1                                                 
                  DCDX(L)=-(UX(L)+UM(K))*DCDX(L)-(VY(L)+VM(K))*DCDY(L)  
     *                    +Q(L)                                         
 10            CONTINUE                                                 
 20         CONTINUE                                                    
 30      CONTINUE                                                       
CX20522 CALL DOOUTX( 522 )                                              
CY20522 CALL DOOUTY( 522 )                                              
                  ELSE                                                  
CX10523 CALL DOINX( 523 )                                               
CY10523 CALL DOINY( 523 )                                               
         DO 50 K=1,NZTOP                                                
            DO 40 I=1,NX                                                
               L=L+1                                                    
               DCDX(L)=-(UX(L)+UM(K))*DCDX(L)+Q(L)                      
 40         CONTINUE                                                    
 50      CONTINUE                                                       
CX20524 CALL DOOUTX( 524 )                                              
CY20524 CALL DOOUTY( 524 )                                              
      ENDIF                                                             
C                                                                       
C       PERFORM THE HORIZONTAL TIME-INTEGRATION PART FOR C(X,Y,Z)       
C               BY USING THE LEAPFROG SCHEME                            
C                                                                       
      CALL LEAPFR(ISTEP,LOOP,DELTAT,C,DCDX,STEPC)                       
CX40008 CALL SBOUTX (8)                                                 
CY40008 CALL SBOUTY (8)                                                 
C                                                                       
      RETURN                                                            
      END                                                               
C                                                                       
C **********************************************************************
C ***     THIS ROUTINE SETS THE VECTORS TO PERFORM THE VERTICAL        *
C ***     INTEGRATION OF THE POLLUTANTS VIA IMPLICIT METHOD (PADE)     *
C ***     VDEP IS THE DRY DEPOSITION VELOCITY (INPUT),                 *
C **********************************************************************
C                                                                       
      SUBROUTINE DCDTZ(NX,NY,NZ,DELTAZ,DELTAT,DZ,IB,IK,C,Q,WZ,HVAR,     
     *VDEP,ZET,HELP,HELPA,DKM,DKZH,CONV,DKS,TIME1,AN,BN,CN,ITY,ISH,     
     *NSMT,DEP,CMASS)                                                   
C                                                                       
      DIMENSION C(NX,NY,NZ),DKZH(NX,NY,NZ),WZ(NX,NY,NZ),Q(NX,NY,NZ)     
      DIMENSION AN(*),BN(*),CN(*),HELP(*),HELPA(*),DKS(*),HVAR(*),ZET(*)
      DIMENSION CONV(*),DKM(*),VDEP(NX,NY),DEP(NX,NY)                   
      COMMON/STRCH/ALP,BET,DH,ZH,UG,VG,T1,T2,DT,TOL,ALPHA,HAMP,BUMP     
CX30009 CALL SBINX (9)                                                  
CY30009 CALL SBINY (9)                                                  
C                                                                       
      CMASS=0.0                                                         
CX10525 CALL DOINX( 525 )                                               
CY10525 CALL DOINY( 525 )                                               
      DO 40 J=1,NY                                                      
         DO 50 I=1,NX                                                   
            VD=VDEP(I,J)                                                
            DO 10 K=1,NZ                                                
               HELP(K)=C(I,J,K)                                         
               DKS(K)=DKZH(I,J,K)                                       
               CONV(K)=WZ(I,J,K)                                        
 10         CONTINUE                                                    
C                                                                       
C     ACCUMULATE THE AMOUNT OF POLLUTANTS DEPOSITED AT THE SURFACE      
C                                                                       
            FLUX=VD*HELP(1)                                             
            DEP(I,J)=DEP(I,J)+DELTAT*FLUX/DELTAZ                        
            Q(I,J,1)=-FLUX/DELTAZ                                       
C                                                                       
            IF(ISH.EQ.1) THEN                                           
               CALL CPADE(DKS,HVAR,HELP,HELPA,NZ,DELTAT,                
     *         DELTAZ,DZ,CONV,AN,BN,CN,IK,ITY,VD)                       
                            ELSE                                        
               CALL CCRANK(DKS,HVAR,HELP,HELPA,NZ,DELTAT,               
     *         DELTAZ,DZ,CONV,AN,BN,CN,IK,ITY,VD)                       
            ENDIF                                                       
            IF(NSMT.EQ.1) CALL SMTH(HELP,ZET,NZ)                        
            DO 30 K=1,NZ                                                
               C(I,J,K)=HELP(K)                                         
               CMASS=CMASS+HELP(K)                                      
 30         CONTINUE                                                    
 50      CONTINUE                                                       
 40   CONTINUE                                                          
CX20526 CALL DOOUTX( 526 )                                              
CY20526 CALL DOOUTY( 526 )                                              
CX40010 CALL SBOUTX (10)                                                
CY40010 CALL SBOUTY (10)                                                
C                                                                       
      RETURN                                                            
      END                                                               
C                                                                       
C **********************************************************************
C *   THIS ROUTINE DOES THE HORIZONTAL ADVECTION PART OF THE SOLUTION  *
C *   FOR THE POTENTIAL TEMPERATURE THETA   USING TIME SPLITTING       *
C **********************************************************************
C                                                                       
      SUBROUTINE  ADVT(NX,NY,NZTOP,ISTEP,LOOP,DELTAT,POTT,STEPT,UX,UM,  
     *VY,VM,DCDX,DCDY)                                                  
C                                                                       
      REAL POTT(1),STEPT(1),UX(1),UM(1),VY(1),VM(1),DCDX(1),DCDY(1)     
CX30011 CALL SBINX (11)                                                 
CY30011 CALL SBINY (11)                                                 
C                                                                       
      L=0                                                               
      IF(NY.GT.1) THEN                                                  
CX10527 CALL DOINX( 527 )                                               
CY10527 CALL DOINY( 527 )                                               
         DO 30 K=1,NZTOP                                                
            DO 20 J=1,NY                                                
               DO 10  I=1,NX                                            
                  L=L+1                                                 
                  DCDX(L)=-(UX(L)+UM(K))*DCDX(L)-(VY(L)+VM(K))*DCDY(L)  
 10            CONTINUE                                                 
 20         CONTINUE                                                    
 30      CONTINUE                                                       
CX20528 CALL DOOUTX( 528 )                                              
CY20528 CALL DOOUTY( 528 )                                              
                  ELSE                                                  
CX10529 CALL DOINX( 529 )                                               
CY10529 CALL DOINY( 529 )                                               
         DO 50 K=1,NZTOP                                                
            DO 40 I=1,NX                                                
               L=L+1                                                    
               DCDX(L)=-(UX(L)+UM(K))*DCDX(L)                           
 40         CONTINUE                                                    
 50      CONTINUE                                                       
CX20530 CALL DOOUTX( 530 )                                              
CY20530 CALL DOOUTY( 530 )                                              
      ENDIF                                                             
C                                                                       
C                                                                       
C                BY USING THE LEAPFROG SCHEME                           
C                                                                       
      CALL LEAPFR(ISTEP,LOOP,DELTAT,POTT,DCDX,STEPT)                    
CX40012 CALL SBOUTX (12)                                                
CY40012 CALL SBOUTY (12)                                                
C                                                                       
      RETURN                                                            
      END                                                               
C                                                                       
C **********************************************************************
C ***     THIS ROUTINE SETS THE VECTORS TO PERFORM THE VERTICAL        *
C ***     INTEGRATION OF THE POTENTIAL TEMPERATURE VIA IMPLICIT METHOD *
C **********************************************************************
C                                                                       
      SUBROUTINE DTDTZ(NX,NY,NZ,DELTAZ,DELTAT,DZ,IB,IK,TM,POTT,WZ,HVAR, 
     *ZET,UNT,HELPA,DKM,DKZH,CONV,DKS,DTM,FORC,TIME1,                   
     *AN,BN,CN,ITY,ISH,NSMT,ELEV,DAYL,HEAT,ISTEP)                       
C                                                                       
      DIMENSION POTT(NX,NY,NZ),DKZH(NX,NY,NZ),WZ(NX,NY,NZ),ELEV(NX,NY)  
      DIMENSION CONV(*)                                                 
      DIMENSION AN(*),BN(*),CN(*),UNT(*),HELPA(*),DKS(*),HVAR(*),ZET(*) 
      DIMENSION DTM(*),FORC(*),DKM(*),TM(*)                             
C                                                                       
      COMMON/STRCH/ALP,BET,DH,ZH,UG,VG,T1,T2,DT,TOL,ALPHA,HAMP,BUMP     
      PARAMETER (PI = 3.141592653589793)                                
CX30013 CALL SBINX (13)                                                 
CY30013 CALL SBINY (13)                                                 
      HEAT=0.0                                                          
      ARG=-((TIME1-BUMP)/DAYL)**2                                       
      TFORC=EXP(ARG)-FLOAT(IB)/10.                                      
C                                                                       
C     UPPER BOUNDARY CONDITION FOR THETA                                
C                                                                       
      UNT(NZ)=0.0                                                       
      NZTOP=NZ-1                                                        
CX10531 CALL DOINX( 531 )                                               
CY10531 CALL DOINY( 531 )                                               
C                                                                       
      DO 40 J=1,NY                                                      
         DO 30 I=1,NX                                                   
C                                                                       
C        SET THE LOWER BOUNDARY CONDITION FOR THE POTENTIAL TEMPERATURE 
C        TIME VARIABLE TIME1,                                           
C                                                                       
            IF(ELEV(I,J).LT.0) THEN                                     
               AMPLT=0.0                                                
                               ELSE                                     
               AMPLT=HAMP                                               
            ENDIF                                                       
            IF(ELEV(I,J).EQ.0.0) AMPLT=HAMP/2.                          
C                                                                       
C       LOWER BOUNDARY CONDITION FOR THETA ACCORDING TO LAND TYPE       
C                                                                       
            UNT(1)=AMPLT*TFORC                                          
C                                                                       
C       PREPARE THE VECTORS FOR THE VERTICAL INTEGRATION                
C       UNT : POTENTIAL TEMPERATURE TO SOLVE FOR                        
C       DKS : TOTAL EDDY DIFFUSIVITY COEFICIENT                         
C       CONV: CONVECTIVE VERTICAL VELOCITY                              
C       DTM : THE SYNOPTIC POTENTIAL TEMPERATURE GRADIENT               
C       SYNFOR : THE TOTAL FORCING VECTOR DUE TO SYNOPTIC CONDITIONS    
C                                                                       
C       ALL THE TERMS THAT FOLLOW REPRESENT THE BOUNDARY LAYER FORCING  
C       DUE TO THE SYNOPTIC CONDITIONS                                  
C                                                                       
            CALL DCTDXF(NZ,1,TM,DTM,DH)                                 
C                                                                       
C       SYNFOR: IS FORCING DUE TO SYNOPTIC EDDY FRICTION                
C       WDTMDH: IS FORCING DUE TO THE CONVECTION OF THE MEAN            
C               POTENTIAL TEMPERATURE  (WDT/DZ)                         
C                                                                       
            DO 10 K=2,NZTOP                                             
               UNT(K)=POTT(I,J,K)                                       
               DKS(K)=DKZH(I,J,K)                                       
               CONV(K)=WZ(I,J,K)                                        
               FKP1=(DKZH(I,J,K+1)-DKM(K+1))*DTM(K+1)*HVAR(K+1)         
               FKM1=(DKZH(I,J,K-1)-DKM(K-1))*DTM(K-1)*HVAR(K-1)         
               WDTMDH=CONV(K)*DTM(K)*HVAR(K)                            
               SYNFOR=HVAR(K)*(FKP1-FKM1)/(2.*DH)                       
               FORC(K)=-WDTMDH+SYNFOR                                   
C                                                                       
 10         CONTINUE                                                    
            CALL SMTHF(FORC,ZET,NZ)                                     
            IF(ISH.EQ.1) THEN                                           
               CALL TPADE(DKS,HVAR,UNT,HELPA,NZ,DELTAT,                 
     *         DELTAZ,DZ,CONV,FORC,AN,BN,CN,IK,ITY)                     
                            ELSE                                        
               CALL TCRANK(DKS,HVAR,UNT,HELPA,NZ,DELTAT,                
     *         DELTAZ,DZ,CONV,FORC,AN,BN,CN,IK,ITY)                     
            ENDIF                                                       
            IF(NSMT.EQ.1) CALL SMTH(UNT,ZET,NZ)                         
            DO 20 K=1,NZTOP                                             
               POTT(I,J,K)=UNT(K)                                       
               HEAT=HEAT+UNT(K)                                         
 20         CONTINUE                                                    
 30      CONTINUE                                                       
 40   CONTINUE                                                          
CX20532 CALL DOOUTX( 532 )                                              
CY20532 CALL DOOUTY( 532 )                                              
CX40014 CALL SBOUTX (14)                                                
CY40014 CALL SBOUTY (14)                                                
C                                                                       
      RETURN                                                            
      END                                                               
C                                                                       
C **********************************************************************
C *      HYDROSTATIC PRESSURE CALCULATION THROUGH DERIVATIVE METHOD    *
C *      THUS FINDING THE PRESSURE BY MARCHING DOWNWARDS FROM THE      *
C *      HYDROSTATIC RELATION                                          *
C **********************************************************************
C                                                                       
      SUBROUTINE HYD(NX,NY,NZ,P,PS,TM,T,ZET,HVAR,NSMT,EXNER)            
      REAL P(NX,NY,NZ),PS(NX,NY,NZ),T(NX,NY,NZ),TM(1),ZET(1),HVAR(1)    
      COMMON/STRCH/ALP,BET,DH,ZH,UG,VG,T1,T2,DT,TOL,ALPHA ,HAMP,BUMP    
      PARAMETER (G = 9.81)                                              
CX30015 CALL SBINX (15)                                                 
CY30015 CALL SBINY (15)                                                 
C                                                                       
      EXNER=0.0                                                         
CX10533 CALL DOINX( 533 )                                               
CY10533 CALL DOINY( 533 )                                               
      DO 30 K=2,NZ                                                      
         DO 20 I=1,NX                                                   
            DO 10 J=1,NY                                                
               KINT=NZ-K+1                                              
               D0=HVAR(KINT)*TM(KINT)*TM(KINT)                          
               D1=HVAR(KINT+1)*TM(KINT+1)*TM(KINT+1)                    
               RAD=0.5*(T(I,J,KINT)/D0+T(I,J,KINT+1)/D1)                
C                                                                       
C              STORE THE PREVIOUS TIME STEPS TO USE THE PRESSURE        
C              AVERAGING TECHNIQUE                                      
C                                                                       
               PS(I,J,KINT)=P(I,J,KINT)                                 
               P(I,J,KINT)=P(I,J,KINT+1)-DH*G*RAD                       
C                                                                       
C      PRESSURE FOR THE TOP IS 0 AND FOR THE LEVEL NZ+1-K,(K=2...NZ), PI
C                                                                       
               EXNER=EXNER+P(I,J,KINT)                                  
 10         CONTINUE                                                    
 20      CONTINUE                                                       
 30   CONTINUE                                                          
CX20534 CALL DOOUTX( 534 )                                              
CY20534 CALL DOOUTY( 534 )                                              
CX40016 CALL SBOUTX (16)                                                
CY40016 CALL SBOUTY (16)                                                
C                                                                       
      RETURN                                                            
      END                                                               
C                                                                       
C **********************************************************************
C *   THIS ROUTINE DOES THE HORIZONTAL ADVECTION PART OF THE SOLUTION  *
C *   FOR THE U MOMENTUM COMPONENT UX USING TIME SPLITTING             *
C **********************************************************************
C                                                                       
      SUBROUTINE ADVU(NX,NY,NZTOP,ISTEP,LOOP,DELTAT,STEPT,UX,STEPU,     
     *UM,VY,VM,WZ,VG,TM,F,FHAT,DCDX,DCDY)                               
C                                                                       
      REAL STEPT(1),UX(1),UM(1),VY(1),VM(1),WZ(1),DCDX(1),DCDY(1)       
      REAL TM(1),VG(1),STEPU(1)                                         
CX30017 CALL SBINX (17)                                                 
CY30017 CALL SBINY (17)                                                 
      L=0                                                               
      IF(NY.GT.1) THEN                                                  
CX10535 CALL DOINX( 535 )                                               
CY10535 CALL DOINY( 535 )                                               
         DO 30 K=1,NZTOP                                                
            DO 20  J=1,NY                                               
               DO 10 I=1,NX                                             
                  L=L+1                                                 
                  DCDX(L)=-(UX(L)+UM(K))*DCDX(L)-(VY(L)+VM(K))*DCDY(L)  
     *                    +F*(VY(L)-VG(K)*STEPT(L)/TM(K))-FHAT*WZ(L)    
 10            CONTINUE                                                 
 20         CONTINUE                                                    
 30      CONTINUE                                                       
CX20536 CALL DOOUTX( 536 )                                              
CY20536 CALL DOOUTY( 536 )                                              
                  ELSE                                                  
CX10537 CALL DOINX( 537 )                                               
CY10537 CALL DOINY( 537 )                                               
         DO 50 K=1,NZTOP                                                
            DO 40 I=1,NX                                                
               L=L+1                                                    
               DCDX(L)=-(UX(L)+UM(K))*DCDX(L)                           
     *                 +F*(VY(L)-VG(K)*STEPT(L)/TM(K))-FHAT*WZ(L)       
 40         CONTINUE                                                    
 50      CONTINUE                                                       
CX20538 CALL DOOUTX( 538 )                                              
CY20538 CALL DOOUTY( 538 )                                              
      ENDIF                                                             
C                                                                       
C       PERFORM THE HORIZONTAL TIME-INTEGRATION PART FOR U(X,Y,Z)       
C                   BY USING THE LEAPFROG SCHEME                        
C                                                                       
      CALL LEAPFR(ISTEP,LOOP,DELTAT,UX,DCDX,STEPU)                      
CX40018 CALL SBOUTX (18)                                                
CY40018 CALL SBOUTY (18)                                                
C                                                                       
      RETURN                                                            
      END                                                               
C                                                                       
C **********************************************************************
C ***     THIS ROUTINE SETS THE VECTORS TO PERFORM THE VERTICAL        *
C ***     INTEGRATION OF THE U-WIND COMPONENT VIA IMPLICIT METHOD      *
C **********************************************************************
C                                                                       
      SUBROUTINE DUDTZ(NX,NY,NZ,DELTAZ,DELTAT,DZ,IB,IK,UM,UX,WZ,HVAR,   
     *ZET,UNU,HELPA,DKM,DKZM,CONV,DKS,DUM,FORC,DPDX,TIME1,AN,BN,CN,     
     *ITY,ISH,NSMT,TM,UWIND,USQ,ISTEP)                                  
C                                                                       
      DIMENSION DKZM(NX,NY,NZ),DPDX(NX,NY,NZ)                           
      DIMENSION UX(NX,NY,NZ),WZ(NX,NY,NZ)                               
      DIMENSION AN(*),BN(*),CN(*),UNU(*),HELPA(*),DKS(*),HVAR(*)        
      DIMENSION DKM(*),UM(*),TM(*),ZET(*),CONV(*),DUM(*),FORC(*)        
C                                                                       
      COMMON/STRCH/ALP,BET,DH,ZH,UGH,VGH,T1,T2,DT,TOL,ALPHA,HAMP,BUMP   
CX30019 CALL SBINX (19)                                                 
CY30019 CALL SBINY (19)                                                 
C                                                                       
      UWIND=0.0                                                         
      USQ=0.0                                                           
C                                                                       
C     UPPER AND LOUER BOUNDARY CONDITIONS FOR U                         
C                                                                       
      UNU(1)=0.0                                                        
      UNU(NZ)=0.0                                                       
      NZTOP=NZ-1                                                        
CX10539 CALL DOINX( 539 )                                               
CY10539 CALL DOINY( 539 )                                               
C                                                                       
      DO 40 J=1,NY                                                      
         DO 30 I=1,NX                                                   
C                                                                       
C       PREPARE THE VECTORS FOR THE VERTICAL INTEGRATION                
C       UNU : U-WIND COMPONENT TO SOLVE FOR                             
C       DKS : TOTAL EDDY DIFFUSIVITY COEFICIENT                         
C       CONV: CONVECTIVE VERTICAL VELOCITY                              
C       DUM : THE SYNOPTIC U-WIND GRADIENT                              
C       SYNFOR : THE FORCING DUE TO SYNOPTIC CONDITIONS                 
C                                                                       
C       ALL THE TERMS THAT FOLLOW REPRESENT THE BOUNDARY LAYER FORCING  
C       DUE TO THE SYNOPTIC CONDITIONS                                  
C       WDUMDH : THE FORCING DUE TO THE VERTICAL ADVECTION OF THE       
C                SYNOPTIC WIND COMPONENT (WDUDZ)                        
C       PGRAD  : PRESSURE GRADIENT WHICH DRIVES THE HORIZONTAL U-WIND   
C                                                                       
            CALL DCTDXF(NZ,1,UM,DUM,DH)                                 
C                                                                       
C        CALCULATE THE RIGHT HAND SIDE OF THE REMAINING EQUATION        
C        BY ADDING THE MESOSCALE PRESSURE GRADIENTS AS WELL AS          
C        THE CORIOLIS TERMS WICH PLAY THE ROLE OF ADDITIONAL FORCING.   
C                                                                       
C                                                                       
            DO 10 K=2,NZTOP                                             
               UNU(K)=UX(I,J,K)                                         
               DKS(K)=DKZM(I,J,K)                                       
               CONV(K)=WZ(I,J,K)                                        
               FKP1=(DKZM(I,J,K+1)-DKM(K+1))*DUM(K+1)*HVAR(K+1)         
               FKM1=(DKZM(I,J,K-1)-DKM(K-1))*DUM(K-1)*HVAR(K-1)         
               WDUMDH=CONV(K)*DUM(K)*HVAR(K)                            
               PGRAD=-TM(K)*DPDX(I,J,K)                                 
               SYNFOR=HVAR(K)*(FKP1-FKM1)/(2.*DH)                       
C                                                                       
               FORC(K)=-WDUMDH+PGRAD+SYNFOR                             
 10         CONTINUE                                                    
            CALL SMTHF(FORC,ZET,NZ)                                     
C            GOTO 50                                                    
            IF(ISH.EQ.1) THEN                                           
               CALL UPADE(DKS,HVAR,UNU,HELPA,NZ,DELTAT,                 
     *         DELTAZ,DZ,CONV,FORC,AN,BN,CN,IK,ITY)                     
                            ELSE                                        
               CALL UCRANK(DKS,HVAR,UNU,HELPA,NZ,DELTAT,                
     *         DELTAZ,DZ,CONV,FORC,AN,BN,CN,IK,ITY)                     
            ENDIF                                                       
            IF(NSMT.EQ.1) CALL SMTH(UNU,ZET,NZ)                         
            DO 20 K=2,NZTOP                                             
               UX(I,J,K)=UNU(K)                                         
               UWIND=UWIND+UNU(K)                                       
               USQ=USQ+UNU(K)**2                                        
 20         CONTINUE                                                    
 30      CONTINUE                                                       
 40   CONTINUE                                                          
CX20540 CALL DOOUTX( 540 )                                              
CY20540 CALL DOOUTY( 540 )                                              
CX40020 CALL SBOUTX (20)                                                
CY40020 CALL SBOUTY (20)                                                
C                                                                       
      RETURN                                                            
      END                                                               
C                                                                       
C **********************************************************************
C *   THIS ROUTINE DOES THE HORIZONTAL ADVECTION PART OF THE SOLUTION  *
C *   FOR THE Y MOMENTUM COMPONENT VY USING TIME SPLITTING             *
C **********************************************************************
C                                                                       
      SUBROUTINE ADVV(NX,NY,NZTOP,ISTEP,LOOP,DELTAT,STEPT,STEPU,UM,VY,  
     *STEPV,VM,UG,TM,F,DCDX,DCDY)                                       
C                                                                       
      REAL STEPT(1),STEPU(1),UM(1),VY(1),VM(1),DCDX(1),DCDY(1),TM(1)    
      REAL UG(1),STEPV(1)                                               
CX30021 CALL SBINX (21)                                                 
CY30021 CALL SBINY (21)                                                 
      L=0                                                               
      IF(NY.GT.1) THEN                                                  
CX10541 CALL DOINX( 541 )                                               
CY10541 CALL DOINY( 541 )                                               
         DO 30 K=1,NZTOP                                                
            DO 20 J=1,NY                                                
               DO 10 I=1,NX                                             
                 L=L+1                                                  
                 DCDX(L)=-(STEPU(L)+UM(K))*DCDX(L)-(VY(L)+VM(K))*DCDY(L)
     *                   -F*(STEPU(L)-UG(K)*STEPT(L)/TM(K))             
 10            CONTINUE                                                 
 20         CONTINUE                                                    
 30      CONTINUE                                                       
CX20542 CALL DOOUTX( 542 )                                              
CY20542 CALL DOOUTY( 542 )                                              
                  ELSE                                                  
CX10543 CALL DOINX( 543 )                                               
CY10543 CALL DOINY( 543 )                                               
         DO 50 K=1,NZTOP                                                
            DO 40 I=1,NX                                                
               L=L+1                                                    
               DCDX(L)=-(STEPU(L)+UM(K))*DCDX(L)                        
     *                 -F*(STEPU(L)-UG(K)*STEPT(L)/TM(K))               
 40         CONTINUE                                                    
 50      CONTINUE                                                       
CX20544 CALL DOOUTX( 544 )                                              
CY20544 CALL DOOUTY( 544 )                                              
      ENDIF                                                             
C                                                                       
C       PERFORM THE HORIZONTAL TIME-INTEGRATION PART FOR V(X,Y,Z)       
C               BY USING THE LEAPFROG SCHEME                            
C                                                                       
      CALL LEAPFR(ISTEP,LOOP,DELTAT,VY,DCDX,STEPV)                      
CX40022 CALL SBOUTX (22)                                                
CY40022 CALL SBOUTY (22)                                                
C                                                                       
      RETURN                                                            
      END                                                               
C                                                                       
C                                                                       
C **********************************************************************
C ***     THIS ROUTINE SETS THE VECTORS TO PERFORM THE VERTICAL        *
C ***     INTEGRATION OF THE V-WIND COMPONENT VIA IMPLICIT METHOD      *
C **********************************************************************
C                                                                       
      SUBROUTINE DVDTZ(NX,NY,NZ,DELTAZ,DELTAT,DZ,IB,IK,VM,VY,WZ,HVAR,   
     *ZET,UNV,HELPA,DKM,DKZM,CONV,DKS,DVM,FORC,DPDY,                    
     *TIME1,AN,BN,CN,ITY,ISH,NSMT,TM,VWIND,VSQ,ISTEP)                   
C                                                                       
      REAL DKZM(NX,NY,NZ),DPDY(NX,NY,NZ),VY(NX,NY,NZ),WZ(NX,NY,NZ)      
      REAL AN(1),BN(1),CN(1),UNV(1),HELPA(1),DKS(1),HVAR(1)             
      REAL CONV(1),DKM(1),VM(1),DVM(1),FORC(1),ZET(1),TM(1)             
C                                                                       
      COMMON/STRCH/ALP,BET,DH,ZH,UGH,VGH,T1,T2,DT,TOL,ALPHA,HAMP,BUMP   
CX30023 CALL SBINX (23)                                                 
CY30023 CALL SBINY (23)                                                 
C                                                                       
      VWIND=0.0                                                         
      VSQ=0.0                                                           
C                                                                       
C     UPPER AND LOUER BOUNDARY CONDITIONS FOR V                         
C                                                                       
      UNV(1)=0.0                                                        
      UNV(NZ)=0.0                                                       
      NZTOP=NZ-1                                                        
CX10545 CALL DOINX( 545 )                                               
CY10545 CALL DOINY( 545 )                                               
C                                                                       
      DO 40 J=1,NY                                                      
         DO 30 I=1,NX                                                   
C                                                                       
C       PREPARE THE VECTORS FOR THE VERTICAL INTEGRATION                
C       UNV : V-WIND COMPONENT TO SOLVE FOR                             
C       DKS : TOTAL EDDY DIFFUSIVITY COEFICIENT                         
C       CONV: CONVECTIVE VERTICAL VELOCITY                              
C       DVM : THE SYNOPTIC U-WIND GRADIENT                              
C       SYNFOR : THE FORCING DUE TO SYNOPTIC CONDITIONS                 
C                                                                       
C       ALL THE TERMS THAT FOLLOW REPRESENT THE BOUNDARY LAYER FORCING  
C       DUE TO THE SYNOPTIC CONDITIONS                                  
C       WDVMDH : THE FORCING DUE TO THE VERTICAL ADVECTION OF THE       
C                SYNOPTIC WIND COMPONENT (WDVDZ)                        
C       PGRAD  : PRESSURE GRADIENT WHICH DRIVES THE HORIZONTAL V-WIND   
C                                                                       
            CALL DCTDXF(NZ,1,VM,DVM,DH)                                 
C                                                                       
C        CALCULATE THE RIGHT HAND SIDE OF THE REMAINING EQUATION        
C        BY ADDING THE MESOSCALE PRESSURE GRADIENTS AS WELL AS          
C        THE CORIOLIS TERMS WICH PLAY THE ROLE OF ADDITIONAL FORCING.   
C                                                                       
C                                                                       
            DO 10 K=2,NZTOP                                             
               UNV(K)=VY(I,J,K)                                         
               DKS(K)=DKZM(I,J,K)                                       
               CONV(K)=WZ(I,J,K)                                        
               FKP1=(DKZM(I,J,K+1)-DKM(K+1))*DVM(K+1)*HVAR(K+1)         
               FKM1=(DKZM(I,J,K-1)-DKM(K-1))*DVM(K-1)*HVAR(K-1)         
               WDVMDH=CONV(K)*DVM(K)*HVAR(K)                            
               IF(NY.GT.1) THEN                                         
                  PGRAD=-TM(K)*DPDY(I,J,K)                              
                           ELSE                                         
                  PGRAD=0.0                                             
               ENDIF                                                    
               SYNFOR=HVAR(K)*(FKP1-FKM1)/(2.*DH)                       
C                                                                       
               FORC(K)=-WDVMDH+SYNFOR+PGRAD                             
 10         CONTINUE                                                    
            CALL SMTHF(FORC,ZET,NZ)                                     
            IF(ISH.EQ.1) THEN                                           
               CALL UPADE(DKS,HVAR,UNV,HELPA,NZ,DELTAT,                 
     *         DELTAZ,DZ,CONV,FORC,AN,BN,CN,IK,ITY)                     
                            ELSE                                        
               CALL UCRANK(DKS,HVAR,UNV,HELPA,NZ,DELTAT,                
     *         DELTAZ,DZ,CONV,FORC,AN,BN,CN,IK,ITY)                     
            ENDIF                                                       
            IF(NSMT.EQ.1) CALL SMTH(UNV,ZET,NZ)                         
            DO 20 K=2,NZTOP                                             
               VY(I,J,K)=UNV(K)                                         
               VWIND=VWIND+UNV(K)                                       
               VSQ=VSQ+UNV(K)**2                                        
 20         CONTINUE                                                    
 30      CONTINUE                                                       
 40   CONTINUE                                                          
CX20546 CALL DOOUTX( 546 )                                              
CY20546 CALL DOOUTY( 546 )                                              
CX40024 CALL SBOUTX (24)                                                
CY40024 CALL SBOUTY (24)                                                
C                                                                       
      RETURN                                                            
      END                                                               
C                                                                       
C **********************************************************************
C *    SOLVING FOR THE VERTICAL VELOCITY BY INTEGRATING VERTICALLY     *
C *    THE CONTINUITY EQUATION                                         *
C *    VERTICAL VELOCITY          W(X,Y,Z,T)=WZ(I,J,K)                 *
C *    U VELOCITY GRADIENT        DU/DX     =DUDX(I,J,K)               *
C *    V VELOCITY GRADIENT        DV/DY     =DVDY(I,J,K)               *
C *    X,Y TOPOGRAPHY FRADIENTS   DE/DX,DE/DY =EX(I,J),EY(I,J)         *
C **********************************************************************
C                                                                       
      SUBROUTINE WCONT(NX,NY,NZ,UX,VY,WZ,DUDX,DVDY,ZET,EX,EY,           
     *HVAR,NSMT,HELP,HELPA,AN,BN,CN,ITY,WWIND,WSQ,FILZ)                 
C                                                                       
      DIMENSION DUDX(NX,NY,NZ),DVDY(NX,NY,NZ),EX(NX,NY),EY(NX,NY)       
      DIMENSION UX(NX,NY,NZ),VY(NX,NY,NZ),WZ(NX,NY,NZ),FILZ(*)          
      DIMENSION HELP(*),HELPA(*),AN(*),BN(*),CN(*),ZET(*),HVAR(*)       
C                                                                       
      COMMON/STRCH/ALP,BET,DH,ZH,UG,VG,T1,T2,DT,TOL,ALPHA,HAMP,BUMP     
CX30025 CALL SBINX (25)                                                 
CY30025 CALL SBINY (25)                                                 
C                                                                       
      WWIND=0.0                                                         
      WSQ=0.0                                                           
      HELP(1)=0.0                                                       
      HELP(NZ)=0.0                                                      
      NZTOP=NZ-1                                                        
CX10547 CALL DOINX( 547 )                                               
CY10547 CALL DOINY( 547 )                                               
      DO 40 I=1,NX                                                      
         DO 30 J=1,NY                                                   
            DO 10 K=2,NZTOP                                             
               IF(NY.EQ.1) THEN                                         
                  DV=0.0                                                
                           ELSE                                         
                  DV=DVDY(I,J,K)                                        
               ENDIF                                                    
               HELP(K)=FILZ(K)*(DUDX(I,J,K)+DV)                         
 10         CONTINUE                                                    
C                                                                       
C      SOLVE IMPLICITLY FOR THE W FOR EACH VERTICAL LAYER               
C                                                                       
            CALL DWDZ(NZ,ZET,HVAR,HELP,HELPA,AN,BN,CN,ITY)              
            DO 20 K=2,NZTOP                                             
               TOPOW=UX(I,J,K)*EX(I,J)+VY(I,J,K)*EY(I,J)                
               WZ(I,J,K)=HELP(K)+TOPOW                                  
               WWIND=WWIND+WZ(I,J,K)                                    
               WSQ=WSQ+WZ(I,J,K)**2                                     
 20         CONTINUE                                                    
 30      CONTINUE                                                       
 40   CONTINUE                                                          
CX20548 CALL DOOUTX( 548 )                                              
CY20548 CALL DOOUTY( 548 )                                              
C                                                                       
      CALL SMOOTH(WZ,NX,NY,NZ)                                          
CX40026 CALL SBOUTX (26)                                                
CY40026 CALL SBOUTY (26)                                                
C                                                                       
      RETURN                                                            
      END                                                               
                                                                        
C                                                                       
C  *********************************************************************
C  *        CALCULATION OF THE DIFFUSION PART WITH EIGENVALUES         *
C  *********************************************************************
C                                                                       
      SUBROUTINE HORDFC(NX,NX1,XSTART,DELTAX,PI,DELTAT,DX,FX,FXC,       
     *FXX,SAVEX,NT)                                                     
      DIMENSION FX(*), FXC(*),FXX(*), SAVEX(*)                          
CX30027 CALL SBINX (27)                                                 
CY30027 CALL SBINY (27)                                                 
      XEND=XSTART+NX*DELTAX                                             
      PIL=2.0*PI/(NX*(XEND-XSTART))                                     
      XP=FLOAT(NX)                                                      
C                                                                       
C     INITIALIZE  PLAIN FFT                                             
C                                                                       
      CALL RFFTI(NX,SAVEX)                                              
CX10549 CALL DOINX( 549 )                                               
CY10549 CALL DOINY( 549 )                                               
C                                                                       
C     CALCULATE PLAIN COLLOCATION POINTS                                
C                                                                       
      DO 10  I=1,NX1                                                    
         FX(I)=PIL*(I-1)                                                
 10   CONTINUE                                                          
CX20550 CALL DOOUTX( 550 )                                              
CY20550 CALL DOOUTY( 550 )                                              
C                                                                       
C     CALCULATE DIFFUSION EIGENVALUES                                   
C                                                                       
      PILDIF=2.0*PI/(XEND-XSTART)                                       
      DH=DX*DELTAT                                                      
      PILDIF=-(PILDIF**2)*DH                                            
CX10551 CALL DOINX( 551 )                                               
CY10551 CALL DOINY( 551 )                                               
      DO 20  I=2,NX1                                                    
         FX(I)=FX(I)*NX                                                 
         FXX(I)=EXP(NT*PILDIF*(I-1)**2)/XP                              
         FXC(I)=EXP(PILDIF*(I-1)**2)/XP                                 
 20   CONTINUE                                                          
CX20552 CALL DOOUTX( 552 )                                              
CY20552 CALL DOOUTY( 552 )                                              
      FXX(1)=EXP(PILDIF*(NX1**2))/XP                                    
      FXC(1)=EXP(NT*PILDIF*(NX1**2))/XP                                 
CX40028 CALL SBOUTX (28)                                                
CY40028 CALL SBOUTY (28)                                                
      RETURN                                                            
      END                                                               
C                                                                       
C   ********************************************************************
C   *    CALCULATE THE X-DERIVATIVE OF UNKNOWN FUNCTION VIA FFT'S      *
C   *    AND ADD HORIZONTAL DIFFUSION TERMS KXD2/DX2, (EIGENVALUES)    *
C   ********************************************************************
C                                                                       
      SUBROUTINE DCTDX(NX,NY,NX1,NFILT,C,DCDX,HELP,HELPX,FX,FXX,SAVEX)  
      DIMENSION C(NX,NY),DCDX(NX,NY),                                   
     *HELP(*),HELPX(*),FX(*),FXX(*),SAVEX(*)                            
CX30029 CALL SBINX (29)                                                 
CY30029 CALL SBINY (29)                                                 
CX10553 CALL DOINX( 553 )                                               
CY10553 CALL DOINY( 553 )                                               
C                                                                       
      DO 40  J=1,NY                                                     
         DO 10  I=1,NX                                                  
            HELP(I)=C(I,J)                                              
 10      CONTINUE                                                       
C                                                                       
         CALL RFFTF(NX,HELP,SAVEX)                                      
C                                                                       
         II1= 0                                                         
         II2= 1                                                         
         HELPX(1)=HELP(1)/NX                                            
         HELP(1)=0.0                                                    
         DO 20  I=2,NX1                                                 
            II1=II1+2                                                   
            II2=II2+2                                                   
            T1= HELP(II1)*FXX(I)                                        
            T2= HELP(II2)*FXX(I)                                        
            HELPX(II2)=T2                                               
            HELPX(II1)=T1                                               
            HELP(II2)= T1*FX(I)                                         
            HELP(II1)=-T2*FX(I)                                         
 20      CONTINUE                                                       
         IF(NFILT.EQ.0) THEN                                            
            HELPX(NX)=HELP(NX)*FXX(1)                                   
                        ELSE                                            
            HELPX(NX)=0.0                                               
         ENDIF                                                          
         HELP(NX)=0.0                                                   
C                                                                       
C        PERFORM BACKWARD TRANSFORMS                                    
C                                                                       
         CALL RFFTB(NX,HELPX,SAVEX)                                     
         CALL RFFTB(NX,HELP,SAVEX)                                      
C                                                                       
         DO 30  I=1,NX                                                  
            DCDX(I,J)=HELP(I)                                           
            C(I,J)=HELPX(I)                                             
 30      CONTINUE                                                       
 40   CONTINUE                                                          
CX20554 CALL DOOUTX( 554 )                                              
CY20554 CALL DOOUTY( 554 )                                              
CX40030 CALL SBOUTX (30)                                                
CY40030 CALL SBOUTY (30)                                                
C                                                                       
      RETURN                                                            
      END                                                               
C                                                                       
C   ********************************************************************
C   *    CALCULATE THE X-DERIVATIVE OF UNKNOWN FUNCTION VIA FFT'S      *
C   *     NO DIFFUSION EIGENVALUE STEP IS PERFORMED ON THE VARIABLE    *
C   ********************************************************************
C                                                                       
      SUBROUTINE DCTDXD(NX,NY,NX1,NFILT,C,DCDX,HELP,HELPX,FX,FXX,SAVEX) 
      DIMENSION C(NX,NY),DCDX(NX,NY),                                   
     *HELP(*),HELPX(*),FX(*),FXX(*),SAVEX(*)                            
CX30031 CALL SBINX (31)                                                 
CY30031 CALL SBINY (31)                                                 
CX10555 CALL DOINX( 555 )                                               
CY10555 CALL DOINY( 555 )                                               
C                                                                       
      DO 60  J=1,NY                                                     
         DO 10  I=1,NX                                                  
            HELP(I)=C(I,J)                                              
 10      CONTINUE                                                       
C                                                                       
         CALL RFFTF(NX,HELP,SAVEX)                                      
C                                                                       
         FILT=-HELP(NX)/NX                                              
         II1= 0                                                         
         II2= 1                                                         
         HELP(1)=0.0                                                    
         DO 20  I=2,NX1                                                 
            II1=II1+2                                                   
            II2=II2+2                                                   
            T1= HELP(II1)                                               
            T2= HELP(II2)                                               
            HELP(II2)= T1*FX(I)                                         
            HELP(II1)=-T2*FX(I)                                         
 20      CONTINUE                                                       
         HELP(NX)=0.0                                                   
C                                                                       
C        PERFORM BACKWARD TRANSFORM                                     
C                                                                       
         CALL RFFTB(NX,HELP,SAVEX)                                      
C                                                                       
         DO 30  I=1,NX                                                  
            DCDX(I,J)=HELP(I)                                           
 30      CONTINUE                                                       
C                                                                       
C     PERFORM FILTERING                                                 
C                                                                       
         IF(NFILT.EQ.0) GOTO 50                                         
         DO 40 I=1,NX                                                   
            FILT=-FILT                                                  
            C(I,J)=C(I,J)-FILT                                          
 40      CONTINUE                                                       
 50      CONTINUE                                                       
 60   CONTINUE                                                          
CX20556 CALL DOOUTX( 556 )                                              
CY20556 CALL DOOUTY( 556 )                                              
CX40032 CALL SBOUTX (32)                                                
CY40032 CALL SBOUTY (32)                                                
C                                                                       
      RETURN                                                            
      END                                                               
C                                                                       
C   ********************************************************************
C   *     CALCULATE THE Y-DERIVATIVE OF UNKNOWN FUNCTION VIA FFT'S     *
C   *     AND ADD HORIZONTAL DIFFUSION TERMS KYD2/DY2, (EIGENVALUES)   *
C   ********************************************************************
C                                                                       
      SUBROUTINE DCTDY(NX,NY,NY1,NFILT,C,DCDY,HELP,HELPY,FY,FYY,SAVEY)  
      DIMENSION C(NX,NY),DCDY(NX,NY),                                   
     *HELP(*),HELPY(*),FY(*),FYY(*),SAVEY(*)                            
CX30033 CALL SBINX (33)                                                 
CY30033 CALL SBINY (33)                                                 
CX10557 CALL DOINX( 557 )                                               
CY10557 CALL DOINY( 557 )                                               
C                                                                       
      DO 40  I=1,NX                                                     
         DO 10  J=1,NY                                                  
            HELP(J)=C(I,J)                                              
 10      CONTINUE                                                       
C                                                                       
         CALL RFFTF(NY,HELP,SAVEY)                                      
         II1= 0                                                         
         II2= 1                                                         
         HELPY(1)=HELP(1)/NY                                            
         HELP(1)=0.0                                                    
         DO 20  J=2,NY1                                                 
            II1=II1+2                                                   
            II2=II2+2                                                   
            T1= HELP(II1)*FYY(J)                                        
            T2= HELP(II2)*FYY(J)                                        
            HELPY(II2)=T2                                               
            HELPY(II1)=T1                                               
            HELP(II2)= T1*FY(J)                                         
            HELP(II1)=-T2*FY(J)                                         
 20      CONTINUE                                                       
         IF(NFILT.EQ.0) THEN                                            
            HELPY(NY)=HELPY(NY)*FYY(1)                                  
                        ELSE                                            
            HELPY(NY)=0.0                                               
         ENDIF                                                          
         HELP(NY)=0.0                                                   
C                                                                       
C        PERFORM BACKWARD TRANSFORMS                                    
C                                                                       
         CALL RFFTB(NY,HELPY,SAVEY)                                     
         CALL RFFTB(NY,HELP,SAVEY)                                      
C                                                                       
         DO 30  J=1,NY                                                  
            DCDY(I,J)=HELP(J)                                           
            C(I,J)=HELPY(J)                                             
 30      CONTINUE                                                       
 40   CONTINUE                                                          
CX20558 CALL DOOUTX( 558 )                                              
CY20558 CALL DOOUTY( 558 )                                              
CX40034 CALL SBOUTX (34)                                                
CY40034 CALL SBOUTY (34)                                                
      RETURN                                                            
      END                                                               
C                                                                       
C   ********************************************************************
C   *     CALCULATE THE Y-DERIVATIVE OF UNKNOWN FUNCTION VIA FFT'S     *
C   *     NO DIFFUSION EIGENVALUE STEP IS PERFORMED ON THE VARIABLE    *
C   ********************************************************************
C                                                                       
      SUBROUTINE DCTDYD(NX,NY,NY1,NFILT,C,DCDY,HELP,HELPY,FY,FYY,SAVEY) 
      DIMENSION C(NX,NY),DCDY(NX,NY),                                   
     *HELP(*),HELPY(*),FY(*),FYY(*),SAVEY(*)                            
CX30035 CALL SBINX (35)                                                 
CY30035 CALL SBINY (35)                                                 
CX10559 CALL DOINX( 559 )                                               
CY10559 CALL DOINY( 559 )                                               
C                                                                       
      DO 60  I=1,NX                                                     
         DO 10  J=1,NY                                                  
            HELP(J)=C(I,J)                                              
 10      CONTINUE                                                       
C                                                                       
         CALL RFFTF(NY,HELP,SAVEY)                                      
C                                                                       
         FILT=-HELP(NY)/NY                                              
         II1= 0                                                         
         II2= 1                                                         
         HELP(1)=0.0                                                    
         DO 20  J=2,NY1                                                 
            II1=II1+2                                                   
            II2=II2+2                                                   
            T1= HELP(II1)                                               
            T2= HELP(II2)                                               
            HELP(II2)= T1*FY(J)                                         
            HELP(II1)=-T2*FY(J)                                         
 20      CONTINUE                                                       
         HELP(NY)=0.0                                                   
C                                                                       
C        PERFORM BACKWARD TRANSFORM                                     
C                                                                       
         CALL RFFTB(NY,HELP,SAVEY)                                      
C                                                                       
         DO 30  J=1,NY                                                  
            DCDY(I,J)=HELP(J)                                           
 30      CONTINUE                                                       
C                                                                       
C     PERFORM FILTERING                                                 
C                                                                       
         IF(NFILT.EQ.0) GOTO 50                                         
         DO 40 J=1,NY                                                   
            FILT=-FILT                                                  
            C(I,J)=C(I,J)-FILT                                          
 40      CONTINUE                                                       
 50      CONTINUE                                                       
 60   CONTINUE                                                          
CX20560 CALL DOOUTX( 560 )                                              
CY20560 CALL DOOUTY( 560 )                                              
CX40036 CALL SBOUTX (36)                                                
CY40036 CALL SBOUTY (36)                                                
      RETURN                                                            
      END                                                               
C                                                                       
C   ********************************************************************
C   *     CALCULATE THE X-DERIVATIVE OF PRESSURE IMPLICT VIA FFT'S     *
C   *     AND ADD HORIZONTAL DIFFUSION TERMS KXD2/DX2, (EIGENVALUES)   *
C   ********************************************************************
C                                                                       
      SUBROUTINE DPDX(NX,NY,NX1,NFILT,C,STEPC,DCDX,HELP,HELPX,          
     *FX,FXX,FILX,SAVEX)                                                
      DIMENSION C(NX,NY),STEPC(NX,NY),DCDX(NX,NY),                      
     *HELP(*),HELPX(*),FX(*),FXX(*),SAVEX(*),FILX(*)                    
CX30037 CALL SBINX (37)                                                 
CY30037 CALL SBINY (37)                                                 
CX10561 CALL DOINX( 561 )                                               
CY10561 CALL DOINY( 561 )                                               
C                                                                       
      DO 40  J=1,NY                                                     
         DO 10  I=1,NX                                                  
            HELP(I)=(C(I,J)+STEPC(I,J))/2.                              
 10      CONTINUE                                                       
C                                                                       
         CALL RFFTF(NX,HELP,SAVEX)                                      
C                                                                       
         II1= 0                                                         
         II2= 1                                                         
         HELP(1)=0.0                                                    
         DO 20  I=2,NX1                                                 
            II1=II1+2                                                   
            II2=II2+2                                                   
            T1= HELP(II1)*FXX(I)                                        
            T2= HELP(II2)*FXX(I)                                        
            HELP(II2)= T1*FX(I)                                         
            HELP(II1)=-T2*FX(I)                                         
 20      CONTINUE                                                       
         HELP(NX)=0.0                                                   
         CALL RFFTB(NX,HELP,SAVEX)                                      
C                                                                       
         DO 30  I=1,NX                                                  
            DCDX(I,J)=HELP(I)*FILX(I)                                   
 30      CONTINUE                                                       
 40   CONTINUE                                                          
CX20562 CALL DOOUTX( 562 )                                              
CY20562 CALL DOOUTY( 562 )                                              
CX40038 CALL SBOUTX (38)                                                
CY40038 CALL SBOUTY (38)                                                
C                                                                       
      RETURN                                                            
      END                                                               
C                                                                       
C   ********************************************************************
C   *     CALCULATE THE Y-DERIVATIVE OF PRESSURE IMPLICI VIA FFT'S     *
C   *     AND ADD HORIZONTAL DIFFUSION TERMS KYD2/DY2, (EIGENVALUES)   *
C   ********************************************************************
C                                                                       
      SUBROUTINE DPDY(NX,NY,NY1,NFILT,C,STEPC,DCDY,HELP,HELPY,          
     *FY,FYY,FILY,SAVEY)                                                
      DIMENSION C(NX,NY),DCDY(NX,NY),STEPC(NX,NY),                      
     *HELP(*),HELPY(*),FY(*),FYY(*),SAVEY(*),FILY(*)                    
CX30039 CALL SBINX (39)                                                 
CY30039 CALL SBINY (39)                                                 
CX10563 CALL DOINX( 563 )                                               
CY10563 CALL DOINY( 563 )                                               
C                                                                       
      DO 40  I=1,NX                                                     
         DO 10  J=1,NY                                                  
            HELP(J)=(C(I,J)+STEPC(I,J))/2.                              
 10      CONTINUE                                                       
C                                                                       
         CALL RFFTF(NY,HELP,SAVEY)                                      
         II1= 0                                                         
         II2= 1                                                         
         HELP(1)=0.0                                                    
         DO 20  J=2,NY1                                                 
            II1=II1+2                                                   
            II2=II2+2                                                   
            T1= HELP(II1)*FYY(J)                                        
            T2= HELP(II2)*FYY(J)                                        
            HELP(II2)= T1*FY(J)                                         
            HELP(II1)=-T2*FY(J)                                         
 20      CONTINUE                                                       
         HELP(NY)=0.0                                                   
         CALL RFFTB(NY,HELP,SAVEY)                                      
C                                                                       
         DO 30  J=1,NY                                                  
            DCDY(I,J)=HELP(J)*FILY(J)                                   
 30      CONTINUE                                                       
 40   CONTINUE                                                          
CX20564 CALL DOOUTX( 564 )                                              
CY20564 CALL DOOUTY( 564 )                                              
CX40040 CALL SBOUTX (40)                                                
CY40040 CALL SBOUTY (40)                                                
      RETURN                                                            
      END                                                               
C                                                                       
C   ********************************************************************
C   *      CALCULATE THE X-DERIVATIVE OF UNKNOWN FUNCTION VIA FFT'S    *
C   ********************************************************************
C                                                                       
      SUBROUTINE DFTDX(NX,NY,NX1,F,DFDX,HELP,FX,SAVEX)                  
      DIMENSION F(NX,NY),DFDX(NX,NY),HELP(*),FX(*),SAVEX(*)             
CX30041 CALL SBINX (41)                                                 
CY30041 CALL SBINY (41)                                                 
C                                                                       
      XP=FLOAT(NX)                                                      
CX10565 CALL DOINX( 565 )                                               
CY10565 CALL DOINY( 565 )                                               
      DO 40  J=1,NY                                                     
         DO 10  I=1,NX                                                  
            HELP(I)=F(I,J)                                              
 10      CONTINUE                                                       
C                                                                       
C        FORWARD FFT                                                    
C                                                                       
         CALL RFFTF(NX,HELP,SAVEX)                                      
C                                                                       
         II1= 0                                                         
         II2= 1                                                         
         HELP(1)=0.0                                                    
         DO 20  I=2,NX1                                                 
            II1=II1+2                                                   
            II2=II2+2                                                   
            T1= HELP(II1)                                               
            T2= HELP(II2)                                               
            HELP(II2)= T1*FX(I)/XP                                      
            HELP(II1)=-T2*FX(I)/XP                                      
 20      CONTINUE                                                       
         HELP(NX)=0.0                                                   
C                                                                       
C     BACKWARD FFT                                                      
C                                                                       
         CALL RFFTB(NX,HELP,SAVEX)                                      
C                                                                       
         DO 30  I=1,NX                                                  
            DFDX(I,J)=HELP(I)                                           
 30      CONTINUE                                                       
 40   CONTINUE                                                          
CX20566 CALL DOOUTX( 566 )                                              
CY20566 CALL DOOUTY( 566 )                                              
CX40042 CALL SBOUTX (42)                                                
CY40042 CALL SBOUTY (42)                                                
C                                                                       
      RETURN                                                            
      END                                                               
C                                                                       
C   ********************************************************************
C   *      CALCULATE THE Y-DERIVATIVE OF UNKNOWN FUNCTION VIA FFT'S    *
C   ********************************************************************
C                                                                       
      SUBROUTINE DFTDY(NX,NY,NY1,F,DFDY,HELP,FY,SAVEY)                  
      DIMENSION F(NX,NY),DFDY(NX,NY),HELP(*),FY(*),SAVEY(*)             
CX30043 CALL SBINX (43)                                                 
CY30043 CALL SBINY (43)                                                 
C                                                                       
      YP=FLOAT(NY)                                                      
CX10567 CALL DOINX( 567 )                                               
CY10567 CALL DOINY( 567 )                                               
      DO 40  I=1,NX                                                     
         DO 10  J=1,NY                                                  
            HELP(J)=F(I,J)                                              
 10      CONTINUE                                                       
C                                                                       
C        FORWARD FFT                                                    
C                                                                       
         CALL RFFTF(NY,HELP,SAVEY)                                      
C                                                                       
         II1= 0                                                         
         II2= 1                                                         
         HELP(1)=0.0                                                    
         DO 20  J=2,NY1                                                 
            II1=II1+2                                                   
            II2=II2+2                                                   
            T1= HELP(II1)                                               
            T2= HELP(II2)                                               
            HELP(II2)= T1*FY(J)/YP                                      
            HELP(II1)=-T2*FY(J)/YP                                      
 20      CONTINUE                                                       
         HELP(NY)=0.0                                                   
C                                                                       
C        BACKWARD FFT                                                   
C                                                                       
         CALL RFFTB(NY,HELP,SAVEY)                                      
C                                                                       
         DO 30  J=1,NY                                                  
            DFDY(I,J)=HELP(J)                                           
 30      CONTINUE                                                       
 40   CONTINUE                                                          
CX20568 CALL DOOUTX( 568 )                                              
CY20568 CALL DOOUTY( 568 )                                              
CX40044 CALL SBOUTX (44)                                                
CY40044 CALL SBOUTY (44)                                                
      RETURN                                                            
      END                                                               
C                                                                       
C **********************************************************************
C      INFORMATION ON THE SETUP OF ELEMENTS AND BOUNDARY CONDITIONS IN *
C      THE TRIDIAGONAL SOLVER ROUTINES    BY Z. D. CHRISTIDIS          *
C **********************************************************************
C                                                                       
C        GIVEN  NUMBER OF POINTS  NZ,  Z VARIES IN (0,1) ->             
C        NUMBER OF POINTS = (1,NZ)                                      
C                                                                       
C        FOR HOMOGENIOUS BOUNDARY CONDITION AT Z=0 AND  Z=1             
C        WE DO NOT SOLVE FOR THE BOUNDARY POINTS. SO USE:               
C        1) LOOP J=2,NZ-1                                               
C        2) POINTS TO SOLVE FOR =NZ-2                                   
C        3) STARTING ADDRESS IN TRID AT THE (2)   ELEMENT               
C                                                                       
C                                                                       
C        FOR FLUX BOUNDARY CONDITION AT Z=0 , AND HOMOGENIOUS AT Z=1    
C        SOLVE FOR Z=0, DO NOT SOLVE AT Z=1.  USE:                      
C        1) LOOP J=1,NZ-1                                               
C        2) FOR  J=1         CN(J)=CN(J)+BN(J)                          
C                            BN(J)=BN(J)                                
C                            H0=GN(J+1)                                 
C        3) FOR  J>1         CN(J)=CN(J)                                
C                            BN(J)=BN(J)                                
C                            H0=GN(J-1)                                 
C        4) POINTS TO SOLVE FOR =NZ-1                                   
C        5) STARTING ADDRESS IN TRID AT THE (1)   ELEMENT               
C                                                                       
C                                                                       
C        FOR FLUX BOUNDARY CONDITION AT Z=NZ,                           
C                 AND HOMOGENIOUS AT Z=0 USE:                           
C        1) LOOP J=2,NZ                                                 
C        2) FOR  J=NZ        BN(J)=CN(J)+BN(J)                          
C                            CN(J)=CN(J)                                
C                            H2=GN(J-1)                                 
C        3) FOR  J<NZ        BN(J)=BN(J)                                
C                            CN(J)=CN(J)                                
C                            H2=GN(J+1)                                 
C        4) POINTS TO SOLVE FOR =NZ-1                                   
C        5) STARTING ADDRESS IN TRID AT THE (2)   ELEMENT               
C                                                                       
C                                                                       
C        FOR FLUX BOUNDARY CONDITION AT Z=NZ , AND Z=0 USE:             
C        1) LOOP J=1,NZ                                                 
C        2) FOR  J=1         CN(J)=CN(J)+BN(J)                          
C                            BN(J)=BN(J)                                
C                            H0=GN(J+1)                                 
C        3) FOR  J=NZ        BN(J)=CN(J)+BN(J)                          
C                            CN(J)=CN(J)                                
C                            H2=GN(J-1)                                 
C        4) FOR 1<J<NZ       BN(J)=BN(J)                                
C                            CN(J)=CN(J)                                
C                            H0=GN(J-1)                                 
C                            H2=GN(J+1)                                 
C        5) POINTS TO SOLVE FOR =NZ                                     
C        6) STARTING ADDRESS IN TRID AT THE (1)   ELEMENT               
C                                                                       
C                                                                       
C **********************************************************************
C ***     THIS ROUTINE CALCULATES VARIABLE DIFFUSIVITIES IN Z - AXIS   *
C ***     EMPLOYIND THE PADE DERIVATIVES AND CRANK-NICKOLSON TECHNIQUE *
C ***         FOR THE POLLUTANTS C ONLY ]]]                            *
C **********************************************************************
C                                                                       
C                                                                       
      SUBROUTINE CPADE(DKS,HVAR,HELP,HELPA,NS,DELTAT,DELS,DZ,W,AN,BN    
     * ,CN,IK,IT,VDRY)                                                  
      DIMENSION DKS(*),HVAR(*),HELP(*),HELPA(*),AN(*),BN(*),CN(*),W(*)  
      COMMON/STRCH/ALP,BET,DH,ZH,UG,VG,T1,T2,DT,TOL,ALPHA,HAMP,BUMP     
      PARAMETER (F1 = .833333333, F2 = .083333333, F3 = .6666666666,    
     *           BT = 0.166666667)                                      
      PARAMETER (FLUX = 0.0)                                            
CX30045 CALL SBINX (45)                                                 
CY30045 CALL SBINY (45)                                                 
      SS=DELTAT/(2.*DH*DH)                                              
      N1=NS-1                                                           
      NPTS=NS-1                                                         
      JS=1                                                              
C                                                                       
C      EXPON=EXP(2.*DH*VDRY/(DKS(1)*HVAR(1)))                           
C                                                                       
      EXPON=1.0                                                         
CX10569 CALL DOINX( 569 )                                               
CY10569 CALL DOINY( 569 )                                               
      DO 10 J=JS,N1                                                     
         BS=SS*DKS(J)*HVAR(J)*HVAR(J)                                   
C                                                                       
C        FORM THE FORCING ARRAY  TO SOLVE THE KS(S)D2C/DS2 PART         
C                                                                       
         AN(J) =F1+2.*BS                                                
         BN(J)=F2-BS                                                    
         CN(J)=F2-BS                                                    
         H1=HELP(J)                                                     
         H2=HELP(J+1)                                                   
         IF (J.EQ.1) THEN                                               
            CN(J)=CN(J)+BN(J)*EXPON                                     
            H0=HELP(J+1)                                                
                     ELSE                                               
            H0=HELP(J-1)                                                
         ENDIF                                                          
         HELPA(J)=(BS+F2)*(H0+H2)+(F1-2.*BS)*H1                         
 10   CONTINUE                                                          
CX20570 CALL DOOUTX( 570 )                                              
CY20570 CALL DOOUTY( 570 )                                              
      CALL TRID(NPTS,BN(JS),AN(JS),CN(JS),HELPA(JS),HELP(JS))           
      DELT=1.                                                           
      IF(IT.EQ.0) DELT=0.0                                              
                                                                        
C                                                                       
C      FORM THE FORCING ARRAY  TO SOLVE THE (DKS/DS)*(DC/DS) PART       
C                                                                       
      CALL DCTDXF(NS,1,DKS,HELPA,DH)                                    
CX10571 CALL DOINX( 571 )                                               
CY10571 CALL DOINY( 571 )                                               
      DO 20 J=JS,N1                                                     
         AS=(HELPA(J)-W(J)/HVAR(J)-DELT*DKS(J)/ALP)*                    
     *   HVAR(J)*HVAR(J)*DELTAT/(4.*DH)                                 
         AN(J) =F3                                                      
         BN(J)=BT+AS                                                    
         CN(J)=BT-AS                                                    
         H1=HELP(J)                                                     
         H2=HELP(J+1)                                                   
         IF(J.EQ.1) THEN                                                
            CN(J)=CN(J)+BN(J)*EXPON                                     
            H0=HELP(J+1)                                                
                    ELSE                                                
            H0=HELP(J-1)                                                
         ENDIF                                                          
         HELPA(J)=(BT+AS)*H2+F3*H1+(BT-AS)*H0                           
 20   CONTINUE                                                          
CX20572 CALL DOOUTX( 572 )                                              
CY20572 CALL DOOUTY( 572 )                                              
      CALL TRID(NPTS,BN(JS),AN(JS),CN(JS),HELPA(JS),HELP(JS))           
CX40046 CALL SBOUTX (46)                                                
CY40046 CALL SBOUTY (46)                                                
      RETURN                                                            
      END                                                               
C                                                                       
C **********************************************************************
C ***     THIS ROUTINE CALCULATES VARIABLE DIFFUSIVITIES IN Z - AXIS   *
C ***     EMPLOYIND THE PADE DERIVATIVES AND CRANK-NICKOLSON TECHNIQUE *
C ***     COMPLEX VECTORS ONLY                                         *
C **********************************************************************
C                                                                       
      SUBROUTINE PADEC(DKS,DKDS,HVAR,WM,WG,FN,NS,AN,BN,CN,IT)           
      DIMENSION DKS(*),DKDS(*),HVAR(*)                                  
      COMPLEX WM(*),WG(*),FN(*),AN(*),BN(*),CN(*)                       
      COMPLEX H0,H1,H2,GAMMA,CONST                                      
      COMMON/STRCH/ALP,BET,DH,ZH,UG,VG,T1,T2,DT,TOL,ALPHA ,HAMP,BUMP    
      PARAMETER (F1 = .8333333, F2 = .0833333)                          
      PARAMETER (F = 0.0001, F4 = 0.1666667, F3 = .6666667)             
CX30047 CALL SBINX (47)                                                 
CY30047 CALL SBINY (47)                                                 
      SS=DT/(2.0*DH*DH)                                                 
      NS1=NS-1                                                          
      NS2=NS-2                                                          
CX10573 CALL DOINX( 573 )                                               
CY10573 CALL DOINY( 573 )                                               
      DO 10 J=2,NS1                                                     
         BS=SS*DKS(J)*HVAR(J)*HVAR(J)                                   
C                                                                       
C        FORM THE FORCING ARRAY  TO SOLVE THE KS(S)D2C/DS2 PART         
C        AN IS THE MIDDLE DIAGONAL VECTOR,BN, THE FIRST, CN THE LAST.   
C                                                                       
         AN(J)=F1+2.*BS                                                 
         BN(J)=F2-BS                                                    
         CN(J)=F2-BS                                                    
         H0=WM(J-1)                                                     
         H1=WM(J)                                                       
         H2=WM(J+1)                                                     
         IF(J.EQ.NS1) THEN                                              
            CONST=CN(J)*H2                                              
                      ELSE                                              
            CONST=(0.,0.)                                               
         ENDIF                                                          
         FN(J)=(BS+F2)*(H0+H2)+(F1-2.*BS)*H1-CONST                      
 10   CONTINUE                                                          
CX20574 CALL DOOUTX( 574 )                                              
CY20574 CALL DOOUTY( 574 )                                              
      CALL TRIDC(NS2,BN(2),AN(2),CN(2),FN(2),WM(2))                     
C                                                                       
C      FORM THE FORCING ARRAY  TO SOLVE THE (DKS/DS)*(DC/DS) PART       
C                                                                       
      CALL DCTDXF(NS,1,DKS,DKDS,DH)                                     
      DELT=1.                                                           
      IF(IT.EQ.0) DELT=0.0                                              
      GAMMA=CMPLX(0.0,F*DT)                                             
CX10575 CALL DOINX( 575 )                                               
CY10575 CALL DOINY( 575 )                                               
      DO 20 J=2,NS1                                                     
         AS=(DKDS(J)-DELT*DKS(J)/ALP)*HVAR(J)*HVAR(J)*DT/(4.*DH)        
         AN(J)=F3+GAMMA/3.                                              
         BN(J)=F4+AS+GAMMA*F2                                           
         CN(J)=F4-AS+GAMMA*F2                                           
         H0=WM(J-1)                                                     
         H1=WM(J)                                                       
         H2=WM(J+1)                                                     
         IF(J.EQ.NS1) THEN                                              
            CONST=CN(J)*H2                                              
                      ELSE                                              
            CONST=(0.,0.)                                               
         ENDIF                                                          
         FN(J)=(AS+F4-GAMMA*F2)*H2+(F4-AS-GAMMA*F2)*H0+                 
     *   H1*(F3-GAMMA/3.)+GAMMA*WG(J)-CONST                             
 20   CONTINUE                                                          
CX20576 CALL DOOUTX( 576 )                                              
CY20576 CALL DOOUTY( 576 )                                              
      CALL TRIDC(NS2,BN(2),AN(2),CN(2),FN(2),WM(2))                     
CX40048 CALL SBOUTX (48)                                                
CY40048 CALL SBOUTY (48)                                                
      RETURN                                                            
      END                                                               
C                                                                       
C **********************************************************************
C ***     THIS ROUTINE CALCULATES VARIABLE DIFFUSIVITIES IN Z - AXIS   *
C ***     EMPLOYING CRANK-NICKOLSON WITH UPWINDING (A=.5 TECHNIQUE)    *
C ***              FOR POLLUTANTS C ONLY                               *
C **********************************************************************
C                                                                       
      SUBROUTINE CCRANK(DKS,HVAR,HELP,HELPA,NS,DELTAT,DELS,DZ,W,AN,BN,  
     * CN,IK,IT,VDRY)                                                   
      DIMENSION DKS(*),HVAR(*),HELP(*),HELPA(*),AN(*),BN(*),CN(*),W(*)  
      COMMON/STRCH/ALP,BET,DH,ZH,UG,VG,T1,T2,DUT,TOL,ALPHA,HAMP,BUMP    
CX30049 CALL SBINX (49)                                                 
CY30049 CALL SBINY (49)                                                 
      SCND=DELTAT/(DH*DH)                                               
      FRST=DELTAT/(2.*DH)                                               
      N1=NS-1                                                           
      DELT=1.                                                           
      NPTS=NS-1                                                         
      JS=1                                                              
C                                                                       
C      EXPON=EXP(2.*DH*VDRY/(DKS(1)*HVAR(1)))                           
C      FOR THE NATURAL FLUX CONDITION                                   
C                                                                       
      EXPON=1.0                                                         
      IF(IT.EQ.0) DELT=0.0                                              
      CALL DCTDXF(NS,1,DKS,HELPA,DH)                                    
      BETA=1.-ALPHA                                                     
CX10577 CALL DOINX( 577 )                                               
CY10577 CALL DOINY( 577 )                                               
      DO 10 J=JS,N1                                                     
         DL=FRST*HVAR(J)*HVAR(J)*(HELPA(J)-W(J)/HVAR(J)-DELT*DKS(J)/ALP)
         DM=SCND*HVAR(J)*HVAR(J)*DKS(J)                                 
C                                                                       
C        FORM THE FORCING ARRAY  TO SOLVE THE KS(S)D2C/DS2 PART         
C        AN IS THE MIDDLE DIAGONAL VECTOR,BN, THE FIRST, CN THE LAST.   
C                                                                       
         AN(J)=1.+2.*ALPHA*DM                                           
         CN(J)=-ALPHA*(DL+DM)                                           
         BN(J)= ALPHA*(DL-DM)                                           
         H1=HELP(J)                                                     
         H2=HELP(J+1)                                                   
C                                                                       
         IF (J.EQ.1) THEN                                               
            CN(J)=CN(J)+BN(J)*EXPON                                     
            H0=HELP(J+1)                                                
                     ELSE                                               
            H0=HELP(J-1)                                                
         ENDIF                                                          
C                                                                       
         HELPA(J)=BETA*(DL+DM)*H2+(1.-2.*BETA*DM)*H1+                   
     *   BETA*(DM-DL)*H0                                                
 10   CONTINUE                                                          
CX20578 CALL DOOUTX( 578 )                                              
CY20578 CALL DOOUTY( 578 )                                              
      CALL TRID(NPTS,BN(JS),AN(JS),CN(JS),HELPA(JS),HELP(JS))           
CX40050 CALL SBOUTX (50)                                                
CY40050 CALL SBOUTY (50)                                                
      RETURN                                                            
      END                                                               
C                                                                       
C **********************************************************************
C ***     THIS ROUTINE CALCULATES VARIABLE DIFFUSIVITIES IN Z - AXIS   *
C ***     EMPLOYIND ONLY THE CRANK-NICKOLSON TECHNIQUE  COMPLEX MATRIX *
C **********************************************************************
C                                                                       
      SUBROUTINE CRANKC(DKS,DKDS,HVAR,WM,WG,FN,NS,AN,BN,CN,IT)          
      REAL DKS(*),DKDS(*),HVAR(*)                                       
      COMPLEX WM(*),WG(*),FN(*),AN(*),BN(*),CN(*)                       
      COMPLEX H0,H1,H2,GAMMA,CONST                                      
      COMMON/STRCH/ALP,BET,DH,ZH,UG,VG,T1,T2,DT,TOL,ALPHA ,HAMP,BUMP    
      PARAMETER (F = 0.0001)                                            
CX30051 CALL SBINX (51)                                                 
CY30051 CALL SBINY (51)                                                 
      SCND=DT/(DH*DH)                                                   
      FRST=DT/(2.*DH)                                                   
      NS1=NS-1                                                          
      NS2=NS-2                                                          
      DELT=1.                                                           
      IF(IT.EQ.0) DELT=0.0                                              
      CALL DCTDXF(NS,1,DKS,DKDS,DH)                                     
      GAMMA=CMPLX(0.0,F*DT)                                             
      BETA=1.-ALPHA                                                     
CX10579 CALL DOINX( 579 )                                               
CY10579 CALL DOINY( 579 )                                               
      DO 10 J=2,NS1                                                     
         DL=FRST*HVAR(J)*HVAR(J)*(DKDS(J)-DELT*DKS(J)/ALP)              
         DM=SCND*HVAR(J)*HVAR(J)*DKS(J)                                 
C                                                                       
C        FORM THE FORCING ARRAY  TO SOLVE THE KS(S)D2C/DS2 PART         
C        AN IS THE MIDDLE DIAGONAL VECTOR,BN, THE FIRST, CN THE LAST.   
C                                                                       
         AN(J)=1.+ALPHA*(2.*DM+GAMMA)                                   
         CN(J)=-ALPHA*(DL+DM)                                           
         BN(J)= ALPHA*(DL-DM)                                           
         H0=WM(J-1)                                                     
         H1=WM(J)                                                       
         H2=WM(J+1)                                                     
         IF(J.EQ.NS1) THEN                                              
            CONST=CN(J)*H2                                              
                      ELSE                                              
            CONST=(0.,0.)                                               
         ENDIF                                                          
         FN(J)=BETA*(DL+DM)*H2+(1.-BETA*(2.*DM+GAMMA))*H1+              
     * BETA*(DM-DL)*H0+GAMMA*WG(J)-CONST                                
 10   CONTINUE                                                          
CX20580 CALL DOOUTX( 580 )                                              
CY20580 CALL DOOUTY( 580 )                                              
      CALL TRIDC(NS2,BN(2),AN(2),CN(2),FN(2),WM(2))                     
CX40052 CALL SBOUTX (52)                                                
CY40052 CALL SBOUTY (52)                                                
      RETURN                                                            
      END                                                               
C                                                                       
C **********************************************************************
C ***     THIS ROUTINE CALCULATES VARIABLE DIFFUSIVITIES IN Z - AXIS   *
C ***     EMPLOYIND THE PADE DERIVATIVES AND CRANK-NICKOLSON TECHNIQUE *
C ***         FOR THE MOMENTUM U,V ONLY ]]]                            *
C **********************************************************************
C                                                                       
C                                                                       
      SUBROUTINE UPADE(DKS,HVAR,HELP,HELPA,NS,DELTAT,DELS,DZ,W,FORCN,   
     *AN,BN,CN,IK,IT)                                                   
      DIMENSION DKS(*),HVAR(*),HELP(*),HELPA(*),AN(*),BN(*),CN(*),W(*)  
      DIMENSION FORCN(*)                                                
      COMMON/STRCH/ALP,BET,DH,ZH,UG,VG,T1,T2,DT,TOL,ALPHA ,HAMP,BUMP    
      PARAMETER (F1 = .833333333, F2 = .083333333, F3 = .6666666666,    
     *           BT = 0.166666667)                                      
      PARAMETER (FLUX = 0.0)                                            
CX30053 CALL SBINX (53)                                                 
CY30053 CALL SBINY (53)                                                 
      SS=DELTAT/(2.*DH*DH)                                              
      N1=NS-1                                                           
      NPTS=NS-2                                                         
      JS=2                                                              
CX10581 CALL DOINX( 581 )                                               
CY10581 CALL DOINY( 581 )                                               
C                                                                       
      DO 10 J=JS,N1                                                     
         BS=SS*DKS(J)*HVAR(J)*HVAR(J)                                   
C                                                                       
C        FORM THE FORCING ARRAY  TO SOLVE THE KS(S)D2U/DS2 PART         
C                                                                       
         AN(J) =F1+2.*BS                                                
         BN(J)=F2-BS                                                    
         CN(J)=F2-BS                                                    
         H0=HELP(J-1)                                                   
         H1=HELP(J)                                                     
         H2=HELP(J+1)                                                   
C                                                                       
         HELPA(J)=(BS+F2)*(H0+H2)+(F1-2.*BS)*H1                         
 10   CONTINUE                                                          
CX20582 CALL DOOUTX( 582 )                                              
CY20582 CALL DOOUTY( 582 )                                              
      CALL TRID(NPTS,BN(JS),AN(JS),CN(JS),HELPA(JS),HELP(JS))           
      DELT=1.                                                           
      IF(IT.EQ.0) DELT=0.0                                              
C                                                                       
C      FORM THE FORCING ARRAY  TO SOLVE THE (DKS/DS)*(DU/DS) PART       
C                                                                       
      CALL DCTDXF(NS,1,DKS,HELPA,DH)                                    
CX10583 CALL DOINX( 583 )                                               
CY10583 CALL DOINY( 583 )                                               
      DO 20 J=JS,N1                                                     
         AS=(HELPA(J)-W(J)/HVAR(J)-DELT*DKS(J)/ALP)*                    
     *   HVAR(J)*HVAR(J)*DELTAT/(4.*DH)                                 
         AN(J) =F3                                                      
         BN(J)=BT+AS                                                    
         CN(J)=BT-AS                                                    
         H0=HELP(J-1)                                                   
         H1=HELP(J)                                                     
         H2=HELP(J+1)                                                   
C                                                                       
         HELPA(J)=(BT+AS)*H2+F3*H1+(BT-AS)*H0+DELTAT*FORCN(J)           
 20   CONTINUE                                                          
CX20584 CALL DOOUTX( 584 )                                              
CY20584 CALL DOOUTY( 584 )                                              
      CALL TRID(NPTS,BN(JS),AN(JS),CN(JS),HELPA(JS),HELP(JS))           
CX40054 CALL SBOUTX (54)                                                
CY40054 CALL SBOUTY (54)                                                
      RETURN                                                            
      END                                                               
C                                                                       
C **********************************************************************
C ***     THIS ROUTINE CALCULATES VARIABLE DIFFUSIVITIES IN Z - AXIS   *
C ***     EMPLOYIND CRANK-NICKOLSON WITH UPWINDING (A=.5 TECHNIQUE)    *
C ***              FOR MOMENTUM ONLY (U,V)                             *
C **********************************************************************
C                                                                       
      SUBROUTINE UCRANK(DKS,HVAR,HELP,HELPA,NS,DELTAT,DELS,DZ,W,FORCN,  
     *AN,BN,CN,IK,IT)                                                   
      DIMENSION DKS(*),HVAR(*),HELP(*),HELPA(*),AN(*),BN(*),CN(*),W(*)  
      DIMENSION FORCN(*)                                                
      COMMON/STRCH/ALP,BET,DH,ZH,UG,VG,T1,T2,DUT,TOL,ALPHA,HAMP,BUMP    
CX30055 CALL SBINX (55)                                                 
CY30055 CALL SBINY (55)                                                 
      SCND=DELTAT/(DH*DH)                                               
      FRST=DELTAT/(2.*DH)                                               
      N1=NS-1                                                           
      DELT=1.                                                           
      NPTS=NS-2                                                         
      JS=2                                                              
      IF(IT.EQ.0) DELT=0.0                                              
      CALL DCTDXF(NS,1,DKS,HELPA,DH)                                    
      BETA=1.-ALPHA                                                     
CX10585 CALL DOINX( 585 )                                               
CY10585 CALL DOINY( 585 )                                               
      DO 10 J=JS,N1                                                     
         DL=FRST*HVAR(J)*HVAR(J)*(HELPA(J)-W(J)/HVAR(J)-DELT*DKS(J)/ALP)
         DM=SCND*HVAR(J)*HVAR(J)*DKS(J)                                 
C                                                                       
C        FORM THE FORCING ARRAY  TO SOLVE THE KS(S)D2C/DS2 PART         
C        AN IS THE MIDDLE DIAGONAL VECTOR,BN, THE FIRST, CN THE LAST.   
C                                                                       
         AN(J)=1.+2.*ALPHA*DM                                           
         CN(J)=-ALPHA*(DL+DM)                                           
         BN(J)= ALPHA*(DL-DM)                                           
         H0=HELP(J-1)                                                   
         H1=HELP(J)                                                     
         H2=HELP(J+1)                                                   
C                                                                       
         HELPA(J)=BETA*(DL+DM)*H2+(1.-2.*BETA*DM)*H1+                   
     *   BETA*(DM-DL)*H0+DELTAT*FORCN(J)                                
 10   CONTINUE                                                          
CX20586 CALL DOOUTX( 586 )                                              
CY20586 CALL DOOUTY( 586 )                                              
      CALL TRID(NPTS,BN(JS),AN(JS),CN(JS),HELPA(JS),HELP(JS))           
CX40056 CALL SBOUTX (56)                                                
CY40056 CALL SBOUTY (56)                                                
      RETURN                                                            
      END                                                               
                                                                        
C                                                                       
C **********************************************************************
C ***     THIS ROUTINE CALCULATES VARIABLE DIFFUSIVITIES IN Z - AXIS   *
C ***     EMPLOYIND THE PADE DERIVATIVES AND CRANK-NICKOLSON TECHNIQUE *
C ***         FOR THE POTENTIAL TEMPERATURE THETA  ONLY ]]]            *
C **********************************************************************
C                                                                       
C                                                                       
      SUBROUTINE TPADE(DKS,HVAR,HELP,HELPA,NS,DELTAT,DELS,DZ,W,SYNFOR,  
     *AN,BN,CN,IK,IT)                                                   
      DIMENSION DKS(*),HVAR(*),HELP(*),HELPA(*),AN(*),BN(*),CN(*),W(*)  
      DIMENSION SYNFOR(*)                                               
      COMMON/STRCH/ALP,BET,DH,ZH,UG,VG,T1,T2,DT,TOL,ALPHA ,HAMP,BUMP    
      PARAMETER (F1 = .833333333, F2 = .083333333, F3 = .6666666666,    
     *           BT = 0.166666667)                                      
      PARAMETER (FLUX = 0.0)                                            
CX30057 CALL SBINX (57)                                                 
CY30057 CALL SBINY (57)                                                 
      SS=DELTAT/(2.*DH*DH)                                              
      N1=NS-1                                                           
      NPTS=NS-2                                                         
      JS=2                                                              
CX10587 CALL DOINX( 587 )                                               
CY10587 CALL DOINY( 587 )                                               
C                                                                       
      DO 10 J=JS,N1                                                     
         BS=SS*DKS(J)*HVAR(J)*HVAR(J)                                   
C                                                                       
C        FORM THE FORCING ARRAY  TO SOLVE THE KS(S)D2C/DS2 PART         
C                                                                       
         AN(J) =F1+2.*BS                                                
         BN(J)=F2-BS                                                    
         CN(J)=F2-BS                                                    
         H0=HELP(J-1)                                                   
         H1=HELP(J)                                                     
         H2=HELP(J+1)                                                   
         IF(J.EQ.2) THEN                                                
            FORC=BN(J)*H0                                               
                    ELSE                                                
            FORC=0.0                                                    
         ENDIF                                                          
C                                                                       
         HELPA(J)=(BS+F2)*(H0+H2)+(F1-2.*BS)*H1-FORC                    
 10   CONTINUE                                                          
CX20588 CALL DOOUTX( 588 )                                              
CY20588 CALL DOOUTY( 588 )                                              
      CALL TRID(NPTS,BN(JS),AN(JS),CN(JS),HELPA(JS),HELP(JS))           
      DELT=1.                                                           
      IF(IT.EQ.0) DELT=0.0                                              
C                                                                       
C      FORM THE FORCING ARRAY  TO SOLVE THE (DKS/DS)*(DC/DS) PART       
C                                                                       
      CALL DCTDXF(NS,1,DKS,HELPA,DH)                                    
CX10589 CALL DOINX( 589 )                                               
CY10589 CALL DOINY( 589 )                                               
      DO 20 J=JS,N1                                                     
         AS=(HELPA(J)-W(J)/HVAR(J)-DELT*DKS(J)/ALP)*                    
     *   HVAR(J)*HVAR(J)*DELTAT/(4.*DH)                                 
         AN(J) =F3                                                      
         BN(J)=BT+AS                                                    
         CN(J)=BT-AS                                                    
         H0=HELP(J-1)                                                   
         H1=HELP(J)                                                     
         H2=HELP(J+1)                                                   
         IF(J.EQ.2) THEN                                                
            FORC=BN(J)*H0                                               
                    ELSE                                                
            FORC=0.0                                                    
         ENDIF                                                          
C                                                                       
         HELPA(J)=(BT+AS)*H2+F3*H1+(BT-AS)*H0-                          
     *   FORC+DELTAT*SYNFOR(J)                                          
 20   CONTINUE                                                          
CX20590 CALL DOOUTX( 590 )                                              
CY20590 CALL DOOUTY( 590 )                                              
      CALL TRID(NPTS,BN(JS),AN(JS),CN(JS),HELPA(JS),HELP(JS))           
CX40058 CALL SBOUTX (58)                                                
CY40058 CALL SBOUTY (58)                                                
      RETURN                                                            
      END                                                               
C                                                                       
C **********************************************************************
C ***     THIS ROUTINE CALCULATES VARIABLE DIFFUSIVITIES IN Z - AXIS   *
C ***     EMPLOYIND CRANK-NICKOLSON WITH UPWINDING (A=.5 TECHNIQUE)    *
C ***              FOR POTENTIAL TEMPERATURE THETA ONLY ]]]            *
C **********************************************************************
C                                                                       
      SUBROUTINE TCRANK(DKS,HVAR,HELP,HELPA,NS,DELTAT,DELS,DZ,W,SYNFOR, 
     *AN,BN,CN,IK,IT)                                                   
      DIMENSION DKS(*),HVAR(*),HELP(*),HELPA(*),AN(*),BN(*),CN(*),W(*)  
      DIMENSION SYNFOR(*)                                               
      COMMON/STRCH/ALP,BET,DH,ZH,UG,VG,T1,T2,DUT,TOL,ALPHA,HAMP,BUMP    
CX30059 CALL SBINX (59)                                                 
CY30059 CALL SBINY (59)                                                 
      SCND=DELTAT/(DH*DH)                                               
      FRST=DELTAT/(2.*DH)                                               
      N1=NS-1                                                           
      DELT=1.                                                           
      NPTS=NS-2                                                         
      JS=2                                                              
      IF(IT.EQ.0) DELT=0.0                                              
      CALL DCTDXF(NS,1,DKS,HELPA,DH)                                    
      BETA=1.-ALPHA                                                     
CX10591 CALL DOINX( 591 )                                               
CY10591 CALL DOINY( 591 )                                               
      DO 10 J=JS,N1                                                     
         DL=FRST*HVAR(J)*HVAR(J)*(HELPA(J)-W(J)/HVAR(J)-DELT*DKS(J)/ALP)
         DM=SCND*HVAR(J)*HVAR(J)*DKS(J)                                 
C                                                                       
C        FORM THE FORCING ARRAY  TO SOLVE THE KS(S)D2C/DS2 PART         
C        AN IS THE MIDDLE DIAGONAL VECTOR,BN, THE FIRST, CN THE LAST.   
C                                                                       
         AN(J)=1.+2.*ALPHA*DM                                           
         CN(J)=-ALPHA*(DL+DM)                                           
         BN(J)= ALPHA*(DL-DM)                                           
         H0=HELP(J-1)                                                   
         H1=HELP(J)                                                     
         H2=HELP(J+1)                                                   
         IF(J.EQ.2) THEN                                                
            FORC=BN(J)*H0                                               
                    ELSE                                                
            FORC=0.0                                                    
         ENDIF                                                          
C                                                                       
         HELPA(J)=BETA*(DL+DM)*H2+(1.-2.*BETA*DM)*H1+                   
     *   BETA*(DM-DL)*H0 + DELTAT*SYNFOR(J) - FORC                      
 10   CONTINUE                                                          
CX20592 CALL DOOUTX( 592 )                                              
CY20592 CALL DOOUTY( 592 )                                              
      CALL TRID(NPTS,BN(JS),AN(JS),CN(JS),HELPA(JS),HELP(JS))           
CX40060 CALL SBOUTX (60)                                                
CY40060 CALL SBOUTY (60)                                                
      RETURN                                                            
      END                                                               
C                                                                       
C **********************************************************************
C ***     THIS ROUTINE CALCULATES VARIABLE DIFFUSIVITIES IN Z - AXIS   *
C ***     EMPLOYIND THE PADE DERIVATIVES AND CRANK-NICKOLSON TECHNIQUE *
C ***         FOR THE MEAN POTENTIAL TEMPERATURE THETA  ONLY ]]]       *
C ***     ALLOW FLUX ZERO LOWER BOUNDARY CONDITIONS FOR MEAN TM        *
C **********************************************************************
C                                                                       
C                                                                       
      SUBROUTINE TMPADE(DKS,HVAR,HELP,HELPA,NS,AN,BN,CN,IT)             
      DIMENSION DKS(*),HVAR(*),HELP(*),HELPA(*),AN(*),BN(*),CN(*)       
      COMMON/STRCH/ALP,BET,DH,ZH,UG,VG,T1,T2,DT,TOL,ALPHA ,HAMP,BUMP    
      PARAMETER (F1 = .833333333, F2 = .083333333, F3 = .6666666666,    
     *           BT = 0.166666667)                                      
      PARAMETER (FLUX = 0.0)                                            
CX30061 CALL SBINX (61)                                                 
CY30061 CALL SBINY (61)                                                 
      SS=DT/(2.*DH*DH)                                                  
C  FOR FIXED BOUNDARY CONDITIONS                                        
C      NPTS=NS-2                                                        
C      JS=2                                                             
      N1=NS-1                                                           
      NPTS=NS-1                                                         
      JS=1                                                              
CX10593 CALL DOINX( 593 )                                               
CY10593 CALL DOINY( 593 )                                               
C                                                                       
      DO 10 J=JS,N1                                                     
         BS=SS*DKS(J)*HVAR(J)*HVAR(J)                                   
C                                                                       
C        FORM THE FORCING ARRAY  TO SOLVE THE KS(S)D2C/DS2 PART         
C                                                                       
         AN(J) =F1+2.*BS                                                
         BN(J)=F2-BS                                                    
         CN(J)=F2-BS                                                    
         H1=HELP(J)                                                     
         H2=HELP(J+1)                                                   
         FORC=0.0                                                       
         IF (J.EQ.1) THEN                                               
            CN(J)=CN(J)+BN(J)                                           
            H0=HELP(J+1)                                                
                     ELSE                                               
            H0=HELP(J-1)                                                
         ENDIF                                                          
         IF(J.EQ.N1) FORC=CN(J)*H2                                      
C  FOR FIXED LOWER BOUNDARY CONDITIONS                                  
C         H0=HELP(J-1)                                                  
C         IF(J.EQ.2) FORC=BN(J)*H0                                      
C                                                                       
         HELPA(J)=(BS+F2)*(H0+H2)+(F1-2.*BS)*H1-FORC                    
 10   CONTINUE                                                          
CX20594 CALL DOOUTX( 594 )                                              
CY20594 CALL DOOUTY( 594 )                                              
      CALL TRID(NPTS,BN(JS),AN(JS),CN(JS),HELPA(JS),HELP(JS))           
      DELT=1.                                                           
      IF(IT.EQ.0) DELT=0.0                                              
C                                                                       
C      FORM THE FORCING ARRAY  TO SOLVE THE (DTM/DS)*(DK/DS) PART       
C                                                                       
      CALL DCTDXF(NS,1,DKS,HELPA,DH)                                    
CX10595 CALL DOINX( 595 )                                               
CY10595 CALL DOINY( 595 )                                               
      DO 20 J=JS,N1                                                     
         AS=(HELPA(J)-DELT*DKS(J)/ALP)*                                 
     *   HVAR(J)*HVAR(J)*DT/(4.*DH)                                     
         AN(J) =F3                                                      
         BN(J)=BT+AS                                                    
         CN(J)=BT-AS                                                    
         H1=HELP(J)                                                     
         H2=HELP(J+1)                                                   
         FORC=0.0                                                       
C  FOR FIXED BOUNDARY CONDITIONS                                        
C         H0=HELP(J-1)                                                  
C         IF(J.EQ.2) FORC=BN(J)*H0                                      
         IF (J.EQ.1) THEN                                               
            CN(J)=CN(J)+BN(J)                                           
            H0=HELP(J+1)                                                
                     ELSE                                               
            H0=HELP(J-1)                                                
         ENDIF                                                          
         IF(J.EQ.N1) FORC=CN(J)*H2                                      
C                                                                       
         HELPA(J)=(BT+AS)*H2+F3*H1+(BT-AS)*H0-FORC                      
 20   CONTINUE                                                          
CX20596 CALL DOOUTX( 596 )                                              
CY20596 CALL DOOUTY( 596 )                                              
      CALL TRID(NPTS,BN(JS),AN(JS),CN(JS),HELPA(JS),HELP(JS))           
CX40062 CALL SBOUTX (62)                                                
CY40062 CALL SBOUTY (62)                                                
      RETURN                                                            
      END                                                               
C                                                                       
C **********************************************************************
C ***     THIS ROUTINE CALCULATES VARIABLE DIFFUSIVITIES IN Z - AXIS   *
C ***     EMPLOYIND CRANK-NICKOLSON WITH UPWINDING (A=.5 TECHNIQUE)    *
C ***     FOR THE MEAN POTENTIAL TEMPERATURE THETA ONLY ]]]            *
C ***     ALLOW FLUX ZERO LOWER BOUNDARY CONDITIONS FOR MEAN TM        *
C **********************************************************************
C                                                                       
      SUBROUTINE TMCRNK(DKS,HVAR,HELP,HELPA,NS,AN,BN,CN,IT)             
      DIMENSION DKS(*),HVAR(*),HELP(*),HELPA(*),AN(*),BN(*),CN(*)       
      COMMON/STRCH/ALP,BET,DH,ZH,UG,VG,T1,T2,DT,TOL,ALPHA,HAMP,BUMP     
CX30063 CALL SBINX (63)                                                 
CY30063 CALL SBINY (63)                                                 
      SCND=DT/(DH*DH)                                                   
      FRST=DT/(2.*DH)                                                   
C  FOR FIXED BOUNDARY CONDITIONS                                        
C      NPTS=NS-2                                                        
C      JS=2                                                             
      N1=NS-1                                                           
      DELT=1.                                                           
      NPTS=NS-1                                                         
      JS=1                                                              
      IF(IT.EQ.0) DELT=0.0                                              
      CALL DCTDXF(NS,1,DKS,HELPA,DH)                                    
      BETA=1.-ALPHA                                                     
CX10597 CALL DOINX( 597 )                                               
CY10597 CALL DOINY( 597 )                                               
      DO 10 J=JS,N1                                                     
         DL=FRST*HVAR(J)*HVAR(J)*(HELPA(J)-DELT*DKS(J)/ALP)             
         DM=SCND*HVAR(J)*HVAR(J)*DKS(J)                                 
C                                                                       
C        FORM THE FORCING ARRAY  TO SOLVE THE KS(S)D2C/DS2 PART         
C        AN IS THE MIDDLE DIAGONAL VECTOR,BN, THE FIRST, CN THE LAST.   
C                                                                       
         AN(J)=1.+2.*ALPHA*DM                                           
         CN(J)=-ALPHA*(DL+DM)                                           
         BN(J)= ALPHA*(DL-DM)                                           
         H1=HELP(J)                                                     
         H2=HELP(J+1)                                                   
         FORC=0.0                                                       
C                                                                       
C  FOR FIXED BOUNDARY CONDITIONS                                        
C         H0=HELP(J-1)                                                  
C         IF(J.EQ.2) FORC=BN(J)*H0                                      
         IF (J.EQ.1) THEN                                               
            CN(J)=CN(J)+BN(J)                                           
            H0=HELP(J+1)                                                
                     ELSE                                               
            H0=HELP(J-1)                                                
         ENDIF                                                          
         IF(J.EQ.N1) FORC=CN(J)*H2                                      
C                                                                       
         HELPA(J)=BETA*(DL+DM)*H2+(1.-2.*BETA*DM)*H1+                   
     *   BETA*(DM-DL)*H0 - FORC                                         
 10   CONTINUE                                                          
CX20598 CALL DOOUTX( 598 )                                              
CY20598 CALL DOOUTY( 598 )                                              
      CALL TRID(NPTS,BN(JS),AN(JS),CN(JS),HELPA(JS),HELP(JS))           
CX40064 CALL SBOUTX (64)                                                
CY40064 CALL SBOUTY (64)                                                
      RETURN                                                            
      END                                                               
C                                                                       
C **********************************************************************
C ***     THIS ROUTINE CALCULATES IMPLICITLY THE VERTICAL VELOCITIES   *
C ***     EMPLOYIND CRANK-NICKOLSON WITH UPWINDING (A=.5 TECHNIQUE)    *
C **********************************************************************
C                                                                       
      SUBROUTINE DWDZ(NS,ZET,HVAR,HELP,HELPA,AN,BN,CN,IT)               
      DIMENSION HVAR(*),HELP(*),HELPA(*),AN(*),BN(*),CN(*),ZET(*)       
      COMMON/STRCH/ALP,BET,DH,ZH,UG,VG,T1,T2,DUT,TOL,ALPHA,HAMP,BUMP    
CX30065 CALL SBINX (65)                                                 
CY30065 CALL SBINY (65)                                                 
      DL=0.5*DH/ALP                                                     
      N1=NS-1                                                           
      NPTS=NS-2                                                         
      JS=2                                                              
      IF(IT.EQ.0) DL=0.0                                                
CX10599 CALL DOINX( 599 )                                               
CY10599 CALL DOINY( 599 )                                               
      DO 10 J=JS,N1                                                     
C                                                                       
C        FORM THE FORCING ARRAY  TO SOLVE THE KS(S)D2C/DS2 PART         
C        AN IS THE MIDDLE DIAGONAL VECTOR,BN, THE FIRST, CN THE LAST.   
C                                                                       
         AN(J)=-2.                                                      
         CN(J)=1.-DL                                                    
         BN(J)=1.+DL                                                    
         H0=HELP(J-1)                                                   
         H2=HELP(J+1)                                                   
C                                                                       
         HELPA(J)=DH*(H0-H2)/(2.*HVAR(J))                               
 10   CONTINUE                                                          
CX20600 CALL DOOUTX( 600 )                                              
CY20600 CALL DOOUTY( 600 )                                              
      CALL TRID(NPTS,BN(JS),AN(JS),CN(JS),HELPA(JS),HELP(JS))           
CX40066 CALL SBOUTX (66)                                                
CY40066 CALL SBOUTY (66)                                                
      RETURN                                                            
      END                                                               
C                                                                       
C **********************************************************************
C ***     M O D I F I E D   G A U S S I A N   E L I M I N A T I O N    *
C ***     THIS ROUTINE IS A TRIDIAGONAL MATRIX SOLVER.                 *
C ***     GIVEN THAT L IS A TRIDIAGONAL MATRIX, THE ROUTINE SOLVES     *
C ***     FOR G  AT THE SYSTEM   L*G=F WHERE  L=BN,AN,CN               *
C **********************************************************************
C                                                                       
      SUBROUTINE TRID(M,BN,AN,CN,FN,GN)                                 
      DIMENSION AN(*),BN(*),CN(*),FN(*),GN(*)                           
CX30067 CALL SBINX (67)                                                 
CY30067 CALL SBINY (67)                                                 
      M1=M-1                                                            
CX10601 CALL DOINX( 601 )                                               
CY10601 CALL DOINY( 601 )                                               
      DO 10 I=2,M                                                       
         R=BN(I)/AN(I-1)                                                
         AN(I)=AN(I)-R*CN(I-1)                                          
         FN(I)=FN(I)-R*FN(I-1)                                          
   10 CONTINUE                                                          
CX20602 CALL DOOUTX( 602 )                                              
CY20602 CALL DOOUTY( 602 )                                              
C                                                                       
C     BACK SUBSTITUTION                                                 
C                                                                       
      GN(M)=FN(M)/AN(M)                                                 
CX10603 CALL DOINX( 603 )                                               
CY10603 CALL DOINY( 603 )                                               
      DO 20 I=1,M1                                                      
         II=M-I                                                         
         GN(II)=(FN(II)-CN(II)*GN(II+1))/AN(II)                         
   20 CONTINUE                                                          
CX20604 CALL DOOUTX( 604 )                                              
CY20604 CALL DOOUTY( 604 )                                              
CX40068 CALL SBOUTX (68)                                                
CY40068 CALL SBOUTY (68)                                                
      RETURN                                                            
      END                                                               
C                                                                       
C **********************************************************************
C ***     M O D I F I E D   G A U S S I A N   E L I M I N A T I O N    *
C ***     THIS ROUTINE IS A COMPLEX TRIDIAGONAL MATRIX SOLVER.         *
C ***     GIVEN THAT L IS A TRIDIAGONAL MATRIX, THE ROUTINE SOLVES     *
C ***     FOR G  AT THE SYSTEM   L*G=F WHERE  L=BN,AN,CN               *
C **********************************************************************
C                                                                       
      SUBROUTINE TRIDC(M,BN,AN,CN,FN,GN)                                
      COMPLEX AN(1),BN(1),CN(1),FN(1),GN(1)                             
      COMPLEX R                                                         
CX30069 CALL SBINX (69)                                                 
CY30069 CALL SBINY (69)                                                 
      M1=M-1                                                            
CX10605 CALL DOINX( 605 )                                               
CY10605 CALL DOINY( 605 )                                               
      DO 10 I=2,M                                                       
         R=BN(I)/AN(I-1)                                                
         AN(I)=AN(I)-R*CN(I-1)                                          
         FN(I)=FN(I)-R*FN(I-1)                                          
   10 CONTINUE                                                          
CX20606 CALL DOOUTX( 606 )                                              
CY20606 CALL DOOUTY( 606 )                                              
C                                                                       
C     BACK SUBSTITUTION                                                 
C                                                                       
      GN(M)=FN(M)/AN(M)                                                 
CX10607 CALL DOINX( 607 )                                               
CY10607 CALL DOINY( 607 )                                               
      DO 20 I=1,M1                                                      
         II=M-I                                                         
         GN(II)=(FN(II)-CN(II)*GN(II+1))/AN(II)                         
   20 CONTINUE                                                          
CX20608 CALL DOOUTX( 608 )                                              
CY20608 CALL DOOUTY( 608 )                                              
CX40070 CALL SBOUTX (70)                                                
CY40070 CALL SBOUTY (70)                                                
      RETURN                                                            
      END                                                               
C                                                                       
C **********************************************************************
C *   SUBROUTINE  LIPFRG  CARRIES OUT THE TIME-INTEGRATION BY THE USE  *
C *   OF THE WELL-KNOWN LEAP-FROG (MID-POINT) RULE.                    *
C *   FOR DF/DT=LF  (L=DIFFERENTIAL OPERATOR,F=UNKOWN FUNCTION) THEN,  *
C *   F(X1)=F(X0) + 1*DT*{LUF(X0)E}  => EULER FORWARD FOR T=0  AND     *
C *   F(X2)=F(X0) + 2*DT*{LUF(X1)E}  => LEAPFROG FOR T>0               *
C **********************************************************************
C                                                                       
      SUBROUTINE LEAPFR(NSTEP,LOOP,DELTAT,F2,F1,F0)                     
      DIMENSION F2(*),F1(*),F0(*)                                       
CX30071 CALL SBINX (71)                                                 
CY30071 CALL SBINY (71)                                                 
C                                                                       
      IF(NSTEP.GT.1) GOTO 20                                            
CX10609 CALL DOINX( 609 )                                               
CY10609 CALL DOINY( 609 )                                               
C                                                                       
C       USE THE EXPLICIT   EULER   FORMULA AT THE STARTING              
C       PHASE OF THE INTEGRATION PROCESS.                               
C                                                                       
C                                                                       
      DO 10 I=1,LOOP                                                    
         F0(I)=F2(I)                                                    
         F2(I)=F2(I)+DELTAT*F1(I)                                       
 10   CONTINUE                                                          
CX20610 CALL DOOUTX( 610 )                                              
CY20610 CALL DOOUTY( 610 )                                              
CX40072 CALL SBOUTX (72)                                                
CY40072 CALL SBOUTY (72)                                                
      RETURN                                                            
C                                                                       
C       CARRY OUT THE COMPUTATIONS WITH THE BASIC FORMULA               
C       (THE LEAP-FROG RULE; THE MID-POINT RULE).                       
C                                                                       
   20 CONTINUE                                                          
CX10611 CALL DOINX( 611 )                                               
CY10611 CALL DOINY( 611 )                                               
      DO      30      I=1,LOOP                                          
         Y2=F2(I)                                                       
         F2(I)=F0(I)+2.*DELTAT*F1(I)                                    
         F0(I)=Y2                                                       
 30   CONTINUE                                                          
CX20612 CALL DOOUTX( 612 )                                              
CY20612 CALL DOOUTY( 612 )                                              
CX40072 CALL SBOUTX (72)                                                
CY40072 CALL SBOUTY (72)                                                
C                                                                       
      RETURN                                                            
      END                                                               
C                                                                       
C   ********************************************************************
C   *     X-DERIVATIVE OF UNKNOWN FUNCTION VIA FINITE DIDFFERENCES     *
C   ********************************************************************
C                                                                       
      SUBROUTINE DCTDXF(NX,NY,C,DCDX,DELTAX)                            
      DIMENSION C(NX,NY),DCDX(NX,NY)                                    
CX30073 CALL SBINX (73)                                                 
CY30073 CALL SBINY (73)                                                 
      D=12.*DELTAX                                                      
      NX1=NX-1                                                          
      NX2=NX-2                                                          
CX10613 CALL DOINX( 613 )                                               
CY10613 CALL DOINY( 613 )                                               
      DO 20  J=1,NY                                                     
         DO 10  I=3,NX2                                                 
            DCDX(I,J)=(C(I-2,J)-8.*C(I-1,J)+8*C(I+1,J)-C(I+2,J))/D      
 10      CONTINUE                                                       
         DCDX(1,J)=(-25.*C(1,J)+48.*C(2,J)-36.*C(3,J)+16.*C(4,J)        
     *   -3.*C(5,J))/D                                                  
         DCDX(2,J)=(-3.*C(1,J)-10.*C(2,J)+18.*C(3,J)-6.*C(4,J)          
     *   +C(5,J))/D                                                     
         DCDX(NX,J)=(3.*C(NX-4,J)-16.*C(NX-3,J)+36.*C(NX-2,J)           
     *   -48.*C(NX-1,J)+25.*C(NX,J))/D                                  
         DCDX(NX1,J)=(-C(NX-4,J)+6.*C(NX-3,J)-18.*C(NX-2,J)             
     *   +10.*C(NX-1,J)+3.*C(NX,J))/D                                   
 20    CONTINUE                                                         
CX20614 CALL DOOUTX( 614 )                                              
CY20614 CALL DOOUTY( 614 )                                              
CX40074 CALL SBOUTX (74)                                                
CY40074 CALL SBOUTY (74)                                                
C                                                                       
      RETURN                                                            
      END                                                               
C                                                                       
C   ********************************************************************
C   *    Y-DERIVATIVE OF UNKNOWN FUNCTION VIA FINITE DIDFFERENCES      *
C   ********************************************************************
C                                                                       
      SUBROUTINE DCTDYF(NX,NY,C,DCDY,DELTAY)                            
      DIMENSION C(NX,NY),DCDY(NX,NY)                                    
CX30075 CALL SBINX (75)                                                 
CY30075 CALL SBINY (75)                                                 
      D=12.*DELTAY                                                      
      NY1=NY-1                                                          
      NY2=NY-2                                                          
CX10615 CALL DOINX( 615 )                                               
CY10615 CALL DOINY( 615 )                                               
      DO 20  I=1,NX                                                     
         DO 10  J=3,NY2                                                 
            DCDY(I,J)=(C(I,J-2)-8.*C(I,J-1)+8*C(I,J+1)-C(I,J+2))/D      
 10      CONTINUE                                                       
         DCDY(I,1)=(-25.*C(I,1)+48.*C(I,2)-36.*C(I,3)+16.*C(I,4)        
     *   -3.*C(I,5))/D                                                  
         DCDY(I,2)=(-3.*C(I,1)-10.*C(I,2)+18.*C(I,3)-6.*C(I,4)          
     *   +C(I,5))/D                                                     
         DCDY(I,NY)=(3.*C(I,NY-4)-16.*C(I,NY-3)+36.*C(I,NY-2)           
     *   -48.*C(I,NY-1)+25.*C(I,NY))/D                                  
         DCDY(I,NY1)=(-C(I,NY-4)+6.*C(I,NY-3)-18.*C(I,NY-2)             
     *   +10.*C(I,NY-1)+3.*C(I,NY))/D                                   
20     CONTINUE                                                         
CX20616 CALL DOOUTX( 616 )                                              
CY20616 CALL DOOUTY( 616 )                                              
CX40076 CALL SBOUTX (76)                                                
CY40076 CALL SBOUTY (76)                                                
C                                                                       
      RETURN                                                            
      END                                                               
C                                                                       
C **********************************************************************
C **                  STRECH THE VERTICAL VARIABLE                     *
C **   CHANGE THE VERTICAL VARIABLE Z TO A NONDIMENSIONAL H (0,1)      *
C **   AND CALCULATE THE TERMS DH/DZ FOR THE DERIVATIVES               *
C **********************************************************************
C                                                                       
      SUBROUTINE STRECH(FILZ,HVAR,ZET,NZ,DELTAZ,NP,ITYPE)               
      DIMENSION HVAR(*) ,ZET(*),FILZ(*)                                 
      COMMON/STRCH/ALP,BET,DH,ZH,UG,VG,T1,T2,DT,TOL,ALPHA,HAMP,BUMP     
CX30077 CALL SBINX (77)                                                 
CY30077 CALL SBINY (77)                                                 
      D1=FLOAT(NZ-1)                                                    
      DH=1./D1                                                          
      IF(ITYPE.EQ.0) DH=DELTAZ                                          
      H=0.0                                                             
CX10617 CALL DOINX( 617 )                                               
CY10617 CALL DOINY( 617 )                                               
      DO 10 K=1,NZ                                                      
         FILZ(K)=1.0                                                    
         IF(ITYPE.GT.0) THEN                                            
            ARG=H/ALP                                                   
            Z=EXP(ARG)                                                  
            ZET(K)=BET*(Z-1.0)                                          
            HVAR(K)=ALP/(Z*BET)                                         
                       ELSE                                             
            ZET(K)=H                                                    
            HVAR(K)=1.                                                  
         ENDIF                                                          
         H=H+DH                                                         
 10   CONTINUE                                                          
CX20618 CALL DOOUTX( 618 )                                              
CY20618 CALL DOOUTY( 618 )                                              
      FILZ(NZ)=0.0                                                      
      FILZ(NZ-1)=0.25                                                   
      FILZ(NZ-2)=0.5                                                    
      FILZ(NZ-3)=0.75                                                   
      DELTAZ=ZET(2)-ZET(1)                                              
      NP=NZ                                                             
CX10619 CALL DOINX( 619 )                                               
CY10619 CALL DOINY( 619 )                                               
      DO 20 K=2,NZ                                                      
         IF(ZH.GT.ZET(K-1).AND.ZH.LT.ZET(K)) THEN                       
            IF(ABS(ZH-ZET(K-1)).GT.ABS(ZH-ZET(K))) THEN                 
               NP=K                                                     
                                                   ELSE                 
               NP=K-1                                                   
            ENDIF                                                       
         ENDIF                                                          
 20   CONTINUE                                                          
CX20620 CALL DOOUTX( 620 )                                              
CY20620 CALL DOOUTY( 620 )                                              
CX40078 CALL SBOUTX (78)                                                
CY40078 CALL SBOUTY (78)                                                
      RETURN                                                            
      END                                                               
C                                                                       
C **********************************************************************
C *       THREE POINT DISTANCE WEIGHTED SMOOTHER FOR REAL VARIABLES    *
C **********************************************************************
C                                                                       
      SUBROUTINE SMTH(F,Z,NZ)                                           
      REAL F(1),Z(1)                                                    
CX30079 CALL SBINX (79)                                                 
CY30079 CALL SBINY (79)                                                 
      NZ1=NZ-1                                                          
      F1=F(1)                                                           
CX10621 CALL DOINX( 621 )                                               
CY10621 CALL DOINY( 621 )                                               
      DO 10 K=2,NZ1                                                     
         F0=0.5*F(K)+0.125*(Z(K+1)-Z(K-1))*                             
     *   (F(K+1)/(Z(K+1)-Z(K))+F1/(Z(K)-Z(K-1)))                        
         F1=F(K)                                                        
         F(K)=F0                                                        
 10   CONTINUE                                                          
CX20622 CALL DOOUTX( 622 )                                              
CY20622 CALL DOOUTY( 622 )                                              
CX40080 CALL SBOUTX (80)                                                
CY40080 CALL SBOUTY (80)                                                
      RETURN                                                            
      END                                                               
C                                                                       
C **********************************************************************
C *       THREE POINT DISTANCE WEIGHTED SMOOTHER FOR FORCING FUNCTION  *
C **********************************************************************
C                                                                       
      SUBROUTINE SMTHF(F,Z,NZ)                                          
      REAL F(*),Z(*)                                                    
CX30081 CALL SBINX (81)                                                 
CY30081 CALL SBINY (81)                                                 
      NZ2=NZ-2                                                          
      F1=F(2)                                                           
CX10623 CALL DOINX( 623 )                                               
CY10623 CALL DOINY( 623 )                                               
      DO 10 K=3,NZ2                                                     
         F0=0.5*F(K)+0.125*(Z(K+1)-Z(K-1))*                             
     *   (F(K+1)/(Z(K+1)-Z(K))+F1/(Z(K)-Z(K-1)))                        
         F1=F(K)                                                        
         F(K)=F0                                                        
 10   CONTINUE                                                          
CX20624 CALL DOOUTX( 624 )                                              
CY20624 CALL DOOUTY( 624 )                                              
CX40082 CALL SBOUTX (82)                                                
CY40082 CALL SBOUTY (82)                                                
      RETURN                                                            
      END                                                               
C                                                                       
C **********************************************************************
C *       THREE POINT DISTANCE WEIGHTED SMOOTHER FOR COMPLEX VARIABLES *
C **********************************************************************
C                                                                       
      SUBROUTINE CSMTH(F,Z,NZ)                                          
      REAL Z(1)                                                         
      COMPLEX F(1),F1,F0                                                
CX30083 CALL SBINX (83)                                                 
CY30083 CALL SBINY (83)                                                 
      NZ1=NZ-1                                                          
      F1=F(1)                                                           
CX10625 CALL DOINX( 625 )                                               
CY10625 CALL DOINY( 625 )                                               
      DO 10 K=2,NZ1                                                     
         F0=0.5*F(K)+0.125*(Z(K+1)-Z(K-1))*                             
     *   (F(K+1)/(Z(K+1)-Z(K))+F1/(Z(K)-Z(K-1)))                        
         F1=F(K)                                                        
         F(K)=F0                                                        
 10   CONTINUE                                                          
CX20626 CALL DOOUTX( 626 )                                              
CY20626 CALL DOOUTY( 626 )                                              
CX40084 CALL SBOUTX (84)                                                
CY40084 CALL SBOUTY (84)                                                
      RETURN                                                            
      END                                                               
C                                                                       
C  *********************************************************************
C  *                      2-D SETUP SMOOTHING ROUTINE                  *
C  *********************************************************************
C                                                                       
      SUBROUTINE SMOOTH(F,NX,NY,NZ)                                     
      REAL F(1)                                                         
CX30085 CALL SBINX (85)                                                 
CY30085 CALL SBINY (85)                                                 
      MLAG=1                                                            
      NZTOP=NZ-2                                                        
CX10627 CALL DOINX( 627 )                                               
CY10627 CALL DOINY( 627 )                                               
C                                                                       
      DO 10 II=1,NZTOP                                                  
         MLAG=MLAG+NX*NY                                                
         CALL HORSMT(NX,NY,F(MLAG))                                     
 10   CONTINUE                                                          
CX20628 CALL DOOUTX( 628 )                                              
CY20628 CALL DOOUTY( 628 )                                              
CX40086 CALL SBOUTX (86)                                                
CY40086 CALL SBOUTY (86)                                                
C                                                                       
      RETURN                                                            
      END                                                               
C                                                                       
C **********************************************************************
C *         2-D SETUP IMPLICIT SMOOTHING ROUTINE                       *
C **********************************************************************
C                                                                       
      SUBROUTINE SMIM(F,NX,NY,NZ,DL,HELP,HELPA,AN,BN,CN)                
      REAL F(*),HELP(*),HELPA(*),AN(*),BN(*),CN(*)                      
CX30087 CALL SBINX (87)                                                 
CY30087 CALL SBINY (87)                                                 
      MLAG=1                                                            
      NZTOP=NZ-2                                                        
CX10629 CALL DOINX( 629 )                                               
CY10629 CALL DOINY( 629 )                                               
C                                                                       
      DO 10 II=1,NZTOP                                                  
         MLAG=MLAG+NX*NY                                                
         CALL HORIMS(NX,NY,F(MLAG),DL,HELP,HELPA,AN,BN,CN)              
 10   CONTINUE                                                          
CX20630 CALL DOOUTX( 630 )                                              
CY20630 CALL DOOUTY( 630 )                                              
CX40088 CALL SBOUTX (88)                                                
CY40088 CALL SBOUTY (88)                                                
C                                                                       
      RETURN                                                            
      END                                                               
C                                                                       
C **********************************************************************
C *                2-D IMPLICIT SMOOTHING                              *
C **********************************************************************
C                                                                       
      SUBROUTINE HORIMS(NX,NY,F,DL,HELP,HELPA,AN,BN,CN)                 
      REAL F(NX,NY),AN(1),BN(1),CN(1),HELP(1),HELPA(1)                  
CX30089 CALL SBINX (89)                                                 
CY30089 CALL SBINY (89)                                                 
CX10631 CALL DOINX( 631 )                                               
CY10631 CALL DOINY( 631 )                                               
      DO 30 J=1,NY                                                      
         DO 10 I=1,NX                                                   
            HELP(I)=F(I,J)                                              
 10      CONTINUE                                                       
         CALL SMIMP(NX,HELP,HELPA,AN,BN,CN,DL)                          
         DO 20 I=1,NX                                                   
            F(I,J)=HELP(I)                                              
 20      CONTINUE                                                       
 30   CONTINUE                                                          
CX20632 CALL DOOUTX( 632 )                                              
CY20632 CALL DOOUTY( 632 )                                              
      IF(NY.EQ.1) THEN                                                  
CX40090 CALL SBOUTX (90)                                                
CY40090 CALL SBOUTY (90)                                                
      RETURN                                                            
      ENDIF                                                             
CX10633 CALL DOINX( 633 )                                               
CY10633 CALL DOINY( 633 )                                               
      DO 60 I=1,NX                                                      
         DO 40 J=1,NY                                                   
            HELP(J)=F(I,J)                                              
 40      CONTINUE                                                       
         CALL SMIMP(NY,HELP,HELPA,AN,BN,CN,DL)                          
         DO 50 J=1,NY                                                   
            F(I,J)=HELP(J)                                              
 50      CONTINUE                                                       
 60   CONTINUE                                                          
CX20634 CALL DOOUTX( 634 )                                              
CY20634 CALL DOOUTY( 634 )                                              
CX40090 CALL SBOUTX (90)                                                
CY40090 CALL SBOUTY (90)                                                
      RETURN                                                            
      END                                                               
C                                                                       
C **********************************************************************
C ***          THIS ROUTINE SMOOTHS IMPLICITLY HORIZONTAL FIELDS       *
C ***          EMPLOYING CRANK-NICKOLSON WITH UPWINDING A=.5           *
C **********************************************************************
C                                                                       
      SUBROUTINE SMIMP(N,HELP,HELPA,AN,BN,CN,DL)                        
      DIMENSION HELP(*),HELPA(*),AN(*),BN(*),CN(*)                      
CX30091 CALL SBINX (91)                                                 
CY30091 CALL SBINY (91)                                                 
      N1=N-1                                                            
      NPTS=N-2                                                          
      JS=2                                                              
CX10635 CALL DOINX( 635 )                                               
CY10635 CALL DOINY( 635 )                                               
      DO 10 J=JS,N1                                                     
C                                                                       
         AN(J)=2.*(1.+DL)                                               
         CN(J)=1.-DL                                                    
         BN(J)=1.-DL                                                    
         H0=HELP(J-1)                                                   
         H1=HELP(J)                                                     
         H2=HELP(J+1)                                                   
C                                                                       
         FORC=0.0                                                       
         IF(J.EQ.JS) FORC=H0*BN(J)                                      
         IF(J.EQ.N1) FORC=H2*CN(J)                                      
         HELPA(J)=H0+2.*H1+H2 -FORC                                     
 10   CONTINUE                                                          
CX20636 CALL DOOUTX( 636 )                                              
CY20636 CALL DOOUTY( 636 )                                              
      CALL TRID(NPTS,BN(JS),AN(JS),CN(JS),HELPA(JS),HELP(JS))           
CX40092 CALL SBOUTX (92)                                                
CY40092 CALL SBOUTY (92)                                                
      RETURN                                                            
      END                                                               
C                                                                       
C **********************************************************************
C *                         2-D SMOOTHING                              *
C **********************************************************************
C                                                                       
      SUBROUTINE HORSMT(NX,NY,F)                                        
      REAL F(NX,NY)                                                     
CX30093 CALL SBINX (93)                                                 
CY30093 CALL SBINY (93)                                                 
      NX1=NX-1                                                          
      NY1=NY-1                                                          
CX10637 CALL DOINX( 637 )                                               
CY10637 CALL DOINY( 637 )                                               
      DO 20 J=1,NY                                                      
         F1=F(1,J)                                                      
         DO 10 I=2,NX1                                                  
            F0=0.5*F(I,J)+0.25*(F1+F(I+1,J))                            
            F1=F(I,J)                                                   
            F(I,J)=F0                                                   
 10      CONTINUE                                                       
 20   CONTINUE                                                          
CX20638 CALL DOOUTX( 638 )                                              
CY20638 CALL DOOUTY( 638 )                                              
      IF(NY.EQ.1) THEN                                                  
CX40094 CALL SBOUTX (94)                                                
CY40094 CALL SBOUTY (94)                                                
      RETURN                                                            
      ENDIF                                                             
CX10639 CALL DOINX( 639 )                                               
CY10639 CALL DOINY( 639 )                                               
      DO 40 I=1,NX                                                      
         F1=F(I,1)                                                      
         DO 30 J=2,NY1                                                  
            F0=0.5*F(I,J)+0.25*(F1+F(I,J+1))                            
            F1=F(I,J)                                                   
            F(I,J)=F0                                                   
 30      CONTINUE                                                       
 40   CONTINUE                                                          
CX20640 CALL DOOUTX( 640 )                                              
CY20640 CALL DOOUTY( 640 )                                              
CX40094 CALL SBOUTX (94)                                                
CY40094 CALL SBOUTY (94)                                                
      RETURN                                                            
      END                                                               
                                                                        
                                                                        
C                                                                       
C **********************************************************************
C **   SUBROUTINE PRINTR IS CALLED BY THE SUBROUTINES OF               *
C **   PROGRAM ADMDL  AT THE END OF EACH TIME-STEP TO PRINT RESULTS    *
C **********************************************************************
C                                                                       
      SUBROUTINE PRINTR(NX,NY,NZ,NT,XSTART,YSTART,ZSTART,TSTART,DX,DY,  
     *DZ,DELTAX,DELTAY,DELTAZ,DELTAT,TIME1,TOUT,NTIME,C,UM,UX,VM,VY,    
     *THM,POTT,WZ,PRES,DKM,DKZM,DKZH,DEP,NPRINT,NGRAPH,NPSTEP,NGSTEP,   
     *NSTEP,IBT,NWINDX,ISH,NSINKS,NFILT,IB,IK,ITY,NCOUNT,               
     *Z0,ELEV,HMIX,TAVR,OBUK,USTR,TSTR,VDEP,PHI,CMASS,UWIND,USQ,VWIND,  
     *VSQ,WWIND,WSQ,HEAT,EXNER)                                         
      CHARACTER*22 TSCH(16)                                             
      DIMENSION C(*),DKM(*),DKZM(*),DKZH(*),DEP(*),TSTR(*)              
      DIMENSION UM(*),UX(*),VM(*),VY(*),THM(*),POTT(*),WZ(*),PRES(*)    
      DIMENSION Z0(*),ELEV(*),HMIX(*),TAVR(*),OBUK(*),USTR(*),VDEP(*)   
      COMMON/STRCH/ALP,BET,DH,ZH,UG,VG,T1,T2,DUT,TOL,ALPHA,HAMP,BUMP    
      COMMON/LAKE/SX,SIGX,SY,SIGY,ZNOT,SFX,SFY,FLX,FLY,BASE,TSL,H0,ZW,ZL
      COMMON/SOURCE/INIT(2,2),NSOUR(2),IX(2,2),JY(2,2),KZ(2,2),         
     *IVAL(2,2),NSX(2,2),NSY(2,2),NSZ(2,2),ISR(2,2)                     
      COMMON/LEVEL/KK1,KK2,KK3,KK4,IYHOM,IGEO,IUGX,IVGY,LT0,LT1,ICPU    
      SAVE TSCH                                                         
      DATA TSCH/' LEAP  FROG 2ND IN X,Y',' 1.85 PRED-COR  2,3 X ',      
     1' LM FORMULA  3RD  IN X',' 0.4  PRED-COR  2,3  X',                
     2' ADAMS BASHFORD 3RD  X',' ADAMS PRED-COR 2,3  X',                
     3' 1.8 PRED-COR 3,4 IN X',' ADAMS PRED-COR 3,4  X',                
     4'  CRANK-NICKOLSON IN Z','  IMPLICIT PADE   IN Z',                
     5'  BATCH MODE = NO     ','  BATCH MODE = YES    ',                
     6'  REGULAR HEIGHT Z=H  ','  STRECHED Z, Z=F(H)  ',                
     6'  NO FILTER AT ALL    ','  SPECTRAL FILTER     '/                
CX30095 CALL SBINX (95)                                                 
CY30095 CALL SBINY (95)                                                 
C                                                                       
      IF(TIME1.NE.TSTART) GO TO 110                                     
C                                                                       
C        INITIALIZE CPU TIME                                            
C                                                                       
      CALL CPUCLK(TM,0,IBT)                                             
C                                                                       
      WRITE(6,10)                                                       
 10   FORMAT(//////,17X,' SOLVING THE EQUATION ',/,2X,                  
     1 ' DC/DT=U*DC/DX+V*DC/DY+KX*D2C/DX2+KY*DC/DY+D(KZ*DC/DZ)/DZ + Q,',
     2 /,2X,' WHERE C(X,Y,Z,T0)=0 WITH PERIODIC BOUNDARY CONDITIONS IN  
     3  X,Y',/,2X,' AND FLUX VERTICAL BOUNDARY CONDITIONS. ',//)        
      WRITE(6,20)  NX,NY,NZ,NT                                          
      WRITE(8,20)  NX,NY,NZ,NT                                          
 20   FORMAT(//,2X,' X AXIS IS DIVIDED INTO ',I4,'  SUBINTERVALS',/,    
     12X,' Y AXIS IS DIVIDED INTO ',I4,'  SUBINTERVALS',/,              
     12X,' Z AXIS IS DIVIDED INTO ',I4,'  SUBINTERVALS',/,              
     12X,'     ',I5,'  TIME STEPS WERE REQUESTED ',//)                  
      XEND=XSTART+(NX-1)*DELTAX                                         
      YEND=YSTART+(NY-1)*DELTAY                                         
      ZEND=ZSTART+(NZ-1)*DELTAZ                                         
      TEND=TSTART+(NT-1)*DELTAT                                         
      WRITE(6,30) TSCH(11+NWINDX),TSCH(15+NFILT),TSCH(13+ITY)           
      WRITE(8,30) TSCH(11+NWINDX),TSCH(15+NFILT),TSCH(13+ITY)           
 30   FORMAT(3A,/)                                                      
      IF(ITY.EQ.1) THEN                                                 
         WRITE(8,40) BET,ALP,ALPHA                                      
         WRITE(6,40) BET,ALP,ALPHA                                      
 40      FORMAT('   Z=',F5.1,'*(EXP(H/',F4.1,')-1),  UPWIND A=',F4.1,//)
      ENDIF                                                             
      WRITE(6,'(4X,A,//)') 'FOLLOWING NUMBERS ARE IN USER WORLD UNITS'  
      WRITE(8,'(4X,A,//)') 'FOLLOWING NUMBERS ARE IN USER WORLD UNITS'  
 50   FORMAT('   X  DOMAIN  (',F9.1,',',F9.1,'),    DX=',F9.2)          
 60   FORMAT('   Y  DOMAIN  (',F9.1,',',F9.1,'),    DY=',F9.2)          
 70   FORMAT('   Z  DOMAIN  (',F9.1,',',F9.1,'),    DZ=',F9.2)          
 80   FORMAT('   T  DOMAIN  (',F9.1,',',F9.1,'),    DT=',F9.2)          
 90   FORMAT(/,'   CENTRAL LATITUDE ',F6.2,' DEG,    GRAPH STEP ',I3,/) 
      WRITE(6,50) XSTART,XEND,DELTAX                                    
      WRITE(6,60) YSTART,YEND,DELTAY                                    
      WRITE(6,70) ZSTART,ZEND,DELTAZ                                    
      WRITE(6,80) TSTART,TEND,DELTAT                                    
      WRITE(6,90) PHI,NGSTEP                                            
      WRITE(6,100) DX,DY,DZ                                             
      WRITE(8,50) XSTART,XEND,DELTAX                                    
      WRITE(8,60) YSTART,YEND,DELTAY                                    
      WRITE(8,70) ZSTART,ZEND,DELTAZ                                    
      WRITE(8,80) TSTART,TEND,DELTAT                                    
      WRITE(8,90) PHI,NGSTEP                                            
      WRITE(8,100) DX,DY,DZ                                             
 100  FORMAT(/,'  DIFFUSIVITIES   (KX,KY,KZ) = (',3F10.2,')',/)         
      LT=NTIME                                                          
      IF(NX.EQ.1.AND.NY.EQ.1) LT=9                                      
      WRITE(6,30) ' ** TIME SCHEMES USED ** ',TSCH(LT),TSCH(9+ISH)      
      WRITE(8,30) ' ** TIME SCHEMES USED ** ',TSCH(LT),TSCH(9+ISH)      
 110  CONTINUE                                                          
C                                                                       
C       CPU TIME                                                        
C                                                                       
      CALL CPUCLK(TM,1,IBT)                                             
C                                                                       
C   SAVE RESULTS FOR GRAPHING                                           
C                                                                       
                                                                        
      IF(TOUT.LT.1.E-6) GOTO 120                                        
      IF(NGRAPH.EQ.0) GOTO 130                                          
      IF(MOD(NSTEP,NGSTEP).NE.0) GOTO 130                               
 120  CONTINUE                                                          
      CALL GRAPH(NX,NY,NZ,C,UM,UX,VM,VY,THM,POTT,WZ,PRES,DKM,DKZM,      
     *DKZH,DEP,NSTEP,Z0,ELEV,HMIX,TAVR,OBUK,USTR,TSTR,VDEP)             
C                                                                       
C     PRINT TIME STEP, SIMULATION TIME TOTAL MASS, MOMENTUM,            
C     HEAT  ENERGY AND CPU TIME                                         
C                                                                       
 130  DMOM=UWIND+VWIND+WWIND                                            
      ENER=USQ+VSQ+WSQ                                                  
      TS=POTT(1)+THM(1)                                                 
C                                                                       
      IF(MOD(NSTEP,NPSTEP).EQ.0)                                        
     *WRITE(6,140)  NSTEP,TIME1,CMASS,ENER,HEAT,EXNER,                  
     *TS,TM,UWIND,VWIND,WWIND                                           
      IF(MOD(NSTEP,NPSTEP).EQ.0)                                        
     *WRITE(8,150)  NSTEP,TIME1,TM,CMASS,ENER,HEAT,EXNER,               
     *UWIND,VWIND,WWIND                                                 
 140  FORMAT(' T(',I6,')=',F8.1,'  FUM=',E11.4,'  E=',E11.4,            
     *'  T=',E11.4,'  P=',E11.4,/,8X,'TS=',F7.2,2X,                     
     *' CPU=',E11.4,'  U=',E11.4,'  V=',E11.4,'  W=',E11.4)             
 150  FORMAT(' T(',I4,')=',F6.0,' CP=',E11.4,'  C=',E10.3,              
     *'  E=',E10.3,'  T=',E10.3,'  P=',E10.3,'  U=',                    
     *E10.3,'  V=',E10.3,'  W=',E10.3)                                  
      IF(NSTEP.EQ.NT) THEN                                              
        WRITE(1,2)                                                      
        WRITE(1,5) CMASS,ENER,WWIND                                     
        IF(CMASS.LT.1.0E6 .AND. ENER.LT.1.0E5 .AND. WWIND.LT.1.0E2)     
     *    THEN                                                          
            WRITE(1,3)                                                  
          ELSE                                                          
            WRITE(1,4)                                                  
        ENDIF                                                           
      ENDIF                                                             
C                                                                       
C   SAVE RESULTS FOR GRAPHING                                           
C                                                                       
      TOUT=TOUT+DELTAT                                                  
C                                                                       
C     SAVE DATA IN FILE FOR RESTORING                                   
C                                                                       
      IF(MOD(NSTEP,NPSTEP).NE.0) THEN                                   
CX40096 CALL SBOUTX (96)                                                
CY40096 CALL SBOUTY (96)                                                
      RETURN                                                            
      ENDIF                                                             
C     OPEN(10,FILE='RUN')                                               
      OPEN(10,FILE='APO10',STATUS='UNKNOWN')                            
      WRITE(10,160) NX,NY,NZ,NT,NTIME,NFILT,NCOUNT,ITY,IB,IK,           
     1NWINDX,ISH,NSINKS,NPRINT,NPSTEP,NGRAPH,NGSTEP ,NSOUR(1),          
     2NSOUR(2),INIT(1,1),INIT(2,1),INIT(1,2),INIT(2,2),IX(1,1),         
     3IX(2,1),IX(1,2),IX(2,2),JY(1,1),JY(2,1),JY(1,2),JY(2,2) ,         
     4KZ(1,1),KZ(2,1),KZ(1,2),KZ(2,2),IVAL(1,1),IVAL(2,1),IVAL(1,2),    
     5IVAL(2,2),NSX(1,1),NSX(2,1),NSX(1,2),NSX(2,2),NSY(1,1),           
     6NSY(2,1),NSY(1,2),NSY(2,2),NSZ(1,1),NSZ(2,1),NSZ(1,2),            
     7NSZ(2,2),ISR(1,1),ISR(2,1),ISR(1,2),ISR(2,2),KK1,KK2,KK3,KK4      
      WRITE(10,170) TIME1,DELTAT,XSTART,DELTAX,DX,YSTART,DELTAY,DY,     
     5ZSTART,DELTAZ,DZ,ALP,BET,ZH,UG,VG,T1,T2,DUT,TOL,ALPHA,            
     6SX,SIGX,SY,SIGY                                                   
   2  FORMAT(1X,'VALIDATION PARAMETERS:'/)                              
   3  FORMAT(//1X,'RESULTS FOR THIS RUN ARE:   VALID')                  
   4  FORMAT(//1X,'RESULTS FOR THIS RUN ARE: INVALID')                  
   5  FORMAT(1X,3E14.5)                                                 
 160  FORMAT(I15)                                                       
 170  FORMAT(F20.4)                                                     
      CLOSE(10)                                                         
CX40096 CALL SBOUTX (96)                                                
CY40096 CALL SBOUTY (96)                                                
C                                                                       
      RETURN                                                            
      END                                                               
C                                                                       
C **********************************************************************
C *   SUBROUTINE TO DUMP THE RESULTED MODEL GENERATED FIELDS FOR       *
C *   LATER EVALUATION BY PLOTTING BOUNDARY LAYER AND OTHER VARBLS     *
C **********************************************************************
C                                                                       
      SUBROUTINE GRAPH(NX,NY,NZ,C,UM,UX,VM,VY,THM,POTT,WZ,PRES,DKM,DKZM,
     *DKZH,DEP,NSTEP,Z0,ELEV,HMIX,TAVR,OBUK,USTR,TSTR,VDEP)             
C                                                                       
      REAL C(NX,NY,NZ),UX(NX,NY,NZ),VY(NX,NY,NZ),WZ(NX,NY,NZ)           
      REAL POTT(NX,NY,NZ),PRES(NX,NY,NZ),DKZM(NX,NY,NZ),DKZH(NX,NY,NZ)  
      REAL Z0(NX,NY),ELEV(NX,NY),HMIX(NX,NY),TAVR(NX,NY)                
      REAL OBUK(NX,NY),USTR(NX,NY),VDEP(NX,NY),DEP(NX,NY),TSTR(NX,NY)   
      REAL UM(NZ),VM(NZ),THM(NZ),DKM(NZ)                                
      COMMON/LEVEL/KK1,KK2,KK3,KK4,IYHOM,IGEO,IUGX,IVGY,LT0,LT1,ICPU    
CX30097 CALL SBINX (97)                                                 
CY30097 CALL SBINY (97)                                                 
      IX0=3                                                             
      IX1=NX-2                                                          
      JY0=1                                                             
      JY1=NY                                                            
      IF(NY.GT.1) THEN                                                  
         JY0=3                                                          
         JY1=NY-2                                                       
      ENDIF                                                             
CX10641 CALL DOINX( 641 )                                               
CY10641 CALL DOINY( 641 )                                               
      DO 40 K=1,NZ                                                      
         IF(NY.GT.1) THEN                                               
            IF(K.EQ.KK1) GOTO 10                                        
            IF(K.EQ.KK2) GOTO 10                                        
            IF(K.EQ.KK3) GOTO 10                                        
            IF(K.EQ.KK4) GOTO 10                                        
            GOTO 40                                                     
         ENDIF                                                          
 10      CONTINUE                                                       
         DO 30 J=JY0,JY1                                                
            DO 20 I=IX0,IX1                                             
               U=UX(I,J,K)+UM(K)                                        
               V=VY(I,J,K)+VM(K)                                        
               THETA=POTT(I,J,K)+THM(K)                                 
C                                                                       
C      WRITE THE CONCENTRATION, TOTAL WIND, POT. TEMPERATURE,           
C      DIFFUSIVITIES AND PRESSURE                                       
C                                                                       
               WRITE(7,50) U,V,WZ(I,J,K),C(I,J,K),THETA,PRES(I,J,K),    
     *                     DKZM(I,J,K),DKZH(I,J,K)                      
C                                                                       
C    WRITE BOUNDARY LAYER PARAMETERS WHEN K=1 OR AT THE SURFACE         
C                                                                       
               IF(K.EQ.1) THEN                                          
                  RATE=C(I,J,1)*VDEP(I,J)                               
                  WRITE(11,50) RATE,TAVR(I,J),OBUK(I,J),                
     *            USTR(I,J),TSTR(I,J),HMIX(I,J),VDEP(I,J),DEP(I,J)      
               ENDIF                                                    
 20         CONTINUE                                                    
 30      CONTINUE                                                       
 40   CONTINUE                                                          
CX20642 CALL DOOUTX( 642 )                                              
CY20642 CALL DOOUTY( 642 )                                              
C                                                                       
 50   FORMAT(8E12.5)                                                    
CX40098 CALL SBOUTX (98)                                                
CY40098 CALL SBOUTY (98)                                                
      RETURN                                                            
      END                                                               
C                                                                       
C **********************************************************************
C *       RUN STATISTICS IN CPU TIMES FOR EACH OF THE EQUATIONS        *
C **********************************************************************
C                                                                       
      SUBROUTINE STATS                                                  
      COMMON/CPU/CINIT,CINHC,CINVC,CINHT,CINVT,CINPI,CINHU,CINVU,       
     *CINHV,CINVV,CINHW,CINVW,CINPR,CINBL,CINFL,CINMN,TM1,TM18,TM19     
CX30099 CALL SBINX (99)                                                 
CY30099 CALL SBINY (99)                                                 
      IF(TM19.LT.0.) THEN                                               
         WRITE(6,10)                                                    
         WRITE(8,10)                                                    
                     ELSE                                               
         WRITE(6,20)                                                    
         WRITE(8,20)                                                    
      ENDIF                                                             
C                                                                       
      CALL CPUCLK(TM18,1,0)                                             
C                                                                       
      TOTAL=TM18-TM1                                                    
      WRITE(6,30) TOTAL,CINIT                                           
      WRITE(8,30) TOTAL,CINIT                                           
      C=CINHC+CINVC                                                     
      T=CINHT+CINVT                                                     
      U=CINHU+CINVU                                                     
      V=CINHV+CINVV                                                     
      W=CINHW+CINVW                                                     
      WRITE(6,40) C,T,CINPI,U,V,W,CINPR,CINBL,CINFL,CINMN               
      WRITE(8,40) C,T,CINPI,U,V,W,CINPR,CINBL,CINFL,CINMN               
      SPECT=CINHC+CINHT+CINHU+CINHV+CINHW                               
      FINIT=CINVC+CINVT+CINVU+CINVV+CINVW                               
      TOTFN=CINVC+CINVT+CINVU+CINVV+CINPI+CINVW+CINMN                   
      IF(TM19.LT.0.) THEN                                               
         WRITE(6,50) CINHC,CINVC,CINHT,CINVT,CINHU,CINVU,               
     *               CINHV,CINVV,CINHW,CINVW                            
         WRITE(8,50) CINHC,CINVC,CINHT,CINVT,CINHU,CINVU,               
     *               CINHV,CINVV,CINHW,CINVW                            
         WRITE(6,60) SPECT,FINIT,TOTFN                                  
         WRITE(8,60) SPECT,FINIT,TOTFN                                  
                     ELSE                                               
         WRITE(6,70) SPECT,FINIT,TOTFN                                  
         WRITE(8,70) SPECT,FINIT,TOTFN                                  
      ENDIF                                                             
C                                                                       
 10   FORMAT(/,                                                         
     *' *******************************************************',/,     
     *' **      CPU STATISTICS IN SECONDS FOR THIS RUN       **',/,     
     *' **                                                   **')       
 20   FORMAT(/,                                                         
     *' *******************************************************',/,     
     *' **                 CPU REPORT (SEC)                  **',/,     
     *' **                                                   **')       
 30   FORMAT(                                                           
     *' **          TOTAL RUN CPU  TIME =',F15.2,      '     **',/,     
     *' **          INITIALIZATION TIME =',F15.2,      '     **',/,     
     *' **                                                   **' )      
 40   FORMAT(                                                           
     *' **      CPU FOR CONCENTRATIONS  C =',F15.2,      '   **',/,     
     *' **      CPU FOR TEMPERATURE THETA =',F15.2,      '   **',/,     
     *' **      CPU FOR EXNER PRESSURE PI =',F15.2,      '   **',/,     
     *' **      CPU FOR X MOMENTUM EQ.  U =',F15.2,      '   **',/,     
     *' **      CPU FOR Y MOMENTUM EQ.  V =',F15.2,      '   **',/,     
     *' **      CPU FOR CONTINUITY EQ.  W =',F15.2,      '   **',/,     
     *' **      CPU FOR PRINTING UNKNOWNS =',F15.2,      '   **',/,     
     *' **      CPU FOR  BOUNDARY   LAYER =',F15.2,      '   **',/,     
     *' **      CPU FOR HIGH  PASS FILTER =',F15.2,      '   **',/,     
     *' **      CPU FOR SYNOPTIC VARIABLS =',F15.2,      '   **',/,     
     *' **                                                   **')       
 50   FORMAT(                                                           
     *' **      CPU FOR SPECTRAL     IN C =',F15.2,      '   **',/,     
     *' **      CPU FOR DIFFERENCES  IN C =',F15.2,      '   **',/,     
     *' **      CPU FOR SPECTRAL     IN T =',F15.2,      '   **',/,     
     *' **      CPU FOR DIFFERENCES  IN T =',F15.2,      '   **',/,     
     *' **      CPU FOR SPECTRAL     IN U =',F15.2,      '   **',/,     
     *' **      CPU FOR DIFFERENCES  IN U =',F15.2,      '   **',/,     
     *' **      CPU FOR SPECTRAL     IN V =',F15.2,      '   **',/,     
     *' **      CPU FOR DIFFERENCES  IN V =',F15.2,      '   **',/,     
     *' **      CPU FOR SPECTRAL     IN W =',F15.2,      '   **',/,     
     *' **      CPU FOR DIFFERENCES  IN W =',F15.2,      '   **',/,     
     *' **                                                   **')       
 60   FORMAT(                                                           
     *' **      CPU FOR  SPECTRAL SCHEMES =',F15.2,      '   **',/,     
     *' **      CPU FOR FINITE DIFFERENCE =',F15.2,      '   **',/,     
     *' **      CPU FOR TOTAL DIFFERENCES =',F15.2,      '   **',/,     
     *' **                                                   **',/,     
     *' **             E N D    O F    R U N                 **',/,     
     *' *******************************************************' )      
 70   FORMAT(                                                           
     *' **      CPU FOR  SPECTRAL SCHEMES =',F15.2,      '   **',/,     
     *' **      CPU FOR FINITE DIFFERENCE =',F15.2,      '   **',/,     
     *' **      CPU FOR TOTAL DIFFERENCES =',F15.2,      '   **',/,     
     *' **                                                   **',/,     
     *' *******************************************************',/)     
CX40100 CALL SBOUTX (100)                                               
CY40100 CALL SBOUTY (100)                                               
C                                                                       
      RETURN                                                            
      END                                                               
C                                                                       
C **********************************************************************
C * SET SOURCES OR SINKS AND INITIAL CONDITIONS FOR THE CONCENTRATIONS *
C **********************************************************************
C                                                                       
      SUBROUTINE SETALL(NX,NY,NZ,XSTART,YSTART,ZSTART,                  
     *DELTAX,DELTAY,DELTAZ,C,Q,CMASS)                                   
C                                                                       
      DIMENSION Q(NX,NY,NZ),C(NX,NY,NZ)                                 
      COMMON/SOURCE/INIT(2,2),NSOUR(2),IX(2,2),JY(2,2),KZ(2,2),         
     * IVAL(2,2),NSX(2,2),NSY(2,2),NSZ(2,2),ISR(2,2)                    
      CHARACTER*21  LAB1(2,2),LQ(2)                                     
      SAVE LAB1, LQ                                                     
      DATA LAB1/' SINGLE SOURCES      ',' SINGLE DISTURBANCES ',        
     *' AREA   SOURCES      ',' AREA DISTURBANCES   '/ ,PI2/1.5708/     
      DATA LQ/' UNNORMALIZED SOURCE ',' ACTUAL SOURCE VALUE '/          
CX30101 CALL SBINX (101)                                                
CY30101 CALL SBINY (101)                                                
C                                                                       
      CMASS=0.0                                                         
      IF(NX.GT.1) XN=FLOAT(NX-1)                                        
      IF(NY.GT.1) YN=FLOAT(NY-1)                                        
      IF(NZ.GT.1) ZN=FLOAT(NZ-1)                                        
CX10643 CALL DOINX( 643 )                                               
CY10643 CALL DOINY( 643 )                                               
C                                                                       
C        SPECIFY SOURCES  AND INITIAL CONDITIONS                        
C                                                                       
      DO 110 M=1,2                                                      
         WRITE(6,'(/)')                                                 
         WRITE(8,'(/)')                                                 
C        M=1 SOURCES, M=2 INITIAL CONDITIONS                            
         NSOU=NSOUR(M)                                                  
         DO 100 L=1,NSOU                                                
            IN=INIT(M,L)                                                
            LX=IX(M,L)                                                  
            LY=JY(M,L)                                                  
            LZ=KZ(M,L)                                                  
            LSX=NSX(M,L)                                                
            LSY=NSY(M,L)                                                
            LSZ=NSZ(M,L)                                                
            VAL=FLOAT(IVAL(M,L))                                        
            SR=FLOAT(ISR(M,L))                                          
            IF(LX.EQ.0.OR.LY.EQ.0.OR.LZ.EQ.0) GOTO 100                  
            WRITE(8,'(/,I3,A,A)') NSOU,LAB1(M,IN+1),' WERE CHOSEN '     
            IF(IN.EQ.0.AND.M.EQ.1) THEN                                 
               Q(LX,LY,LZ)=VAL                                          
                                   ELSE                                 
               C(LX,LY,LZ)=VAL                                          
               CMASS=VAL                                                
            ENDIF                                                       
            WRITE(8,10) ' #',L,' ** ',VAL,' ** LOCATED AT',LX,LY,LZ     
 10         FORMAT(/,A,I3,A,E12.4,A,' IX=',I3,' JY=',I3,' KZ=',I3,/)    
            IF(IN.GT.0) THEN                                            
               WRITE(8,20) ' SIGMA ',SR,LSX,LSY,LSZ                     
 20            FORMAT(A,E10.2,' SPREAD IN POINTS AROUND CENTER ',3I4,/) 
               I1=LX-LSX                                                
               I2=LX+LSX                                                
               J1=LY-LSY                                                
               J2=LY+LSY                                                
               K1=LZ-LSZ                                                
               K2=LZ+LSZ                                                
               IF(I1.LT.1) I1=1                                         
               IF(J1.LT.1) J1=1                                         
               IF(K1.LT.1) K1=1                                         
               IF(I2.GT.NX) I2=NX                                       
               IF(J2.GT.NY) J2=NY                                       
               IF(K2.GT.NZ) K2=NZ                                       
               IF(NY.EQ.1) THEN                                         
                  J1=1                                                  
                  J2=1                                                  
               ENDIF                                                    
               IF(NZ.EQ.1) THEN                                         
                  K1=1                                                  
                  K2=1                                                  
               ENDIF                                                    
               TOT=0.                                                   
               DO 60 K=K1,K2                                            
                  DO 50 J=J1,J2                                         
                     DO 40 I=I1,I2                                      
                        IF(NX.EQ.1) THEN                                
                           LX=I                                         
                           XN=1.                                        
                        ENDIF                                           
                        IF(NY.EQ.1) THEN                                
                           LY=J                                         
                           YN=1.                                        
                        ENDIF                                           
                        IF(NZ.EQ.1) THEN                                
                           LZ=K                                         
                           ZN=1.                                        
                        ENDIF                                           
                        X=(PI2*(FLOAT(I-LX)/XN))**2                     
                        Y=(PI2*(FLOAT(J-LY)/YN))**2                     
                        Z=(PI2*(FLOAT(K-LZ)/ZN))**2                     
                        Q1=EXP(-SR*(X+Y+Z))                             
                        TOT=TOT+Q1                                      
                        IF(M.EQ.1) THEN                                 
                           Q(I,J,K)=Q1                                  
                                   ELSE                                 
                           C(I,J,K)=Q1                                  
                           CMASS=CMASS+Q1                               
                        ENDIF                                           
                        WRITE(8,30) LQ(1),Q1,I,J,K                      
 30                     FORMAT(A,E12.4,' AT GRID POINTS I,J,K ',3I4)    
 40                  CONTINUE                                           
 50               CONTINUE                                              
 60            CONTINUE                                                 
               DO 90 K=K1,K2                                            
                  DO 80 J=J1,J2                                         
                     DO 70 I=I1,I2                                      
                        IF(M.EQ.1) THEN                                 
                           Q(I,J,K)= VAL*Q(I,J,K)/TOT                   
                           WRITE(8,30) LQ(2),Q(I,J,K),I,J,K             
                           WRITE(6,30) LQ(2),Q(I,J,K),I,J,K             
                                   ELSE                                 
                           C(I,J,K)= VAL*C(I,J,K)/TOT                   
                           CMASS=CMASS+C(I,J,K)                         
                        ENDIF                                           
 70                  CONTINUE                                           
 80               CONTINUE                                              
 90            CONTINUE                                                 
            ENDIF                                                       
 100     CONTINUE                                                       
 110  CONTINUE                                                          
CX20644 CALL DOOUTX( 644 )                                              
CY20644 CALL DOOUTY( 644 )                                              
CX40102 CALL SBOUTX (102)                                               
CY40102 CALL SBOUTY (102)                                               
      RETURN                                                            
      END                                                               
C                                                                       
C  *********************************************************************
C  *        SUBROUTINE TO AJUST BOUNDARY CONDITIONS AT THE             *
C  *        END OF EACH TIME STEP. (NEUMANN B.C.)                      *
C  *********************************************************************
C                                                                       
      SUBROUTINE HORBC(NX,NY,NZ,NT,XSTART,YSTART,ZSTART,TSTART,         
     * DELTAX,DELTAY,DELTAZ,DELTAT,TIME1,UX,VY,C,Q)                     
C                                                                       
      DIMENSION Q(NX,NY,NZ),C(NX,NY,NZ), UX(NX,NY,NZ), VY(NX,NY,NZ)     
CX30103 CALL SBINX (103)                                                
CY30103 CALL SBINY (103)                                                
      NXB=NX-1                                                          
      NXB2=NX-2                                                         
      NYB=NY-1                                                          
CX10645 CALL DOINX( 645 )                                               
CY10645 CALL DOINY( 645 )                                               
      DO 90 K=1,NZ                                                      
         DO 20  I=1,2                                                   
            DO 10  J=1,NY                                               
               Q(I,J,K)=Q(I,J,K)-ABS(UX(I,J,K))*C(I,J,K)/DELTAX         
 10         CONTINUE                                                    
 20      CONTINUE                                                       
         DO 40 I=NXB,NX                                                 
            DO 30  J=1,NY                                               
               Q(I,J,K)=Q(I,J,K)-ABS(UX(I,J,K))*C(I,J,K)/DELTAX         
 30         CONTINUE                                                    
 40      CONTINUE                                                       
         IF(NY.EQ.1) GOTO 90                                            
         DO 60 J=1,2                                                    
            DO 50  I=3,NXB2                                             
               Q(I,J,K)=Q(I,J,K)-ABS(VY(I,J,K))*C(I,J,K)/DELTAY         
 50         CONTINUE                                                    
 60      CONTINUE                                                       
         DO 80 J=NYB,NY                                                 
            DO 70  I=3,NXB2                                             
               Q(I,J,K)=Q(I,J,K)-ABS(VY(I,J,K))*C(I,J,K)/DELTAY         
 70         CONTINUE                                                    
 80      CONTINUE                                                       
 90   CONTINUE                                                          
CX20646 CALL DOOUTX( 646 )                                              
CY20646 CALL DOOUTY( 646 )                                              
CX40104 CALL SBOUTX (104)                                               
CY40104 CALL SBOUTY (104)                                               
      RETURN                                                            
      END                                                               
C                                                                       
C **********************************************************************
C *      CHECK A PRIORY THE STABILITY LIMITS OF THE SYSTEM             *
C **********************************************************************
C                                                                       
      SUBROUTINE STAB(NX,NY,NTIME,TSTART,NT,IB,HAMP,BUMP,               
     *DELTAX,DELTAY,DELTAT)                                             
C                                                                       
      REAL H(8)                                                         
      SAVE H                                                            
      DATA H/1.,.72,.86,1.2,1.18,1.61,1.95,1.7/                         
CX30105 CALL SBINX (105)                                                
CY30105 CALL SBINY (105)                                                
      A1=H(NTIME)/(DELTAT*3.14)                                         
      A2=FLOAT(NX-2)/(FLOAT(NX)*DELTAX)                                 
      A3=FLOAT(NY-2)/(FLOAT(NY)*DELTAY)                                 
      UT=A1/A2                                                          
      IF(A3.LT.0) A1=0                                                  
      VT=A1/A3                                                          
      WRITE(6,10) UT,VT                                                 
 10   FORMAT(/,' FOR LINEAR STABILITY,  UMAX <',F6.2,'  VMAX <',F6.2,/) 
      TEND1=TSTART+NT*DELTAT                                            
      PERIOD=TEND1-TSTART                                               
      HOUR=PERIOD/3600.                                                 
      BIAS=IB/10.                                                       
      BAMP=BUMP/3600.                                                   
      WRITE(6,20) PERIOD,HOUR,HAMP,BAMP,BIAS                            
 20   FORMAT(' ** TOTAL SIMULATION PERIOD ',F10.1,'S, =',F6.2,          
     *' HOURS **',/,' ** HEAT AMPLITUDE ',F6.2,' K,    LAG =',F6.2,     
     *'(H),   BIAS A ',F6.1,//)                                         
      DUMP=4.9                                                          
      WRITE(6,30) HAMP,BAMP,DUMP,BIAS                                   
      WRITE(8,30) HAMP,BAMP,DUMP,BIAS                                   
 30   FORMAT(' ********   LAND SURFACE FORCING  FUNCTION ********* ',//,
     *' T(X,Y,T)=',F5.1,'{EXP -((T-',F4.1,')/',F4.1,')**2 -',F4.1,'}'   
     *,//,' ********   TIME UNITS ARE IN HOURS        *********',/)     
CX40106 CALL SBOUTX (106)                                               
CY40106 CALL SBOUTY (106)                                               
      RETURN                                                            
      END                                                               
C                                                                       
C **********************************************************************
C *      CALCULATION OF RATES OF MEAN POTENTIAL TEMPERATURE, U,V       *
C *      WIND COMPONENTS AS WELL AS THE GEOSTROPHIC COMPONENTS         *
C **********************************************************************
C                                                                       
      SUBROUTINE SYNSET(TIME)                                           
      COMMON/LEVEL/KK1,KK2,KK3,KK4,IYHOM,IGEO,IUGX,IVGY,LT0,LT1,ICPU    
      COMMON/STRCH/ALP,BET,DH,ZH,UG,VG,T1,T2,DT,TOL,ALPHA,HAMP,BUMP     
CX30107 CALL SBINX (107)                                                
CY30107 CALL SBINY (107)                                                
C                                                                       
C     CALCULATE NEW GEOSTROPHIC WINDS SURFACE AND TOP TEMPERATURES      
C     ACCORDING TO THE GIVEN RATES OF CHANGE. NORMALLY DATA WILL BE     
C     READ IN FROM AN OBSERVATIONAL NETWORK. THE RATES FOR THE WINDS    
C     ARE GIVEN IN CM PER HOURS, WHILE THE TEMPERATURE CHANGES ARE      
C     IN DEGREES PER TEN HOURS                                          
C                                                                       
      UG=UG+TIME*IUGX/360000.                                           
      VG=VG+TIME*IVGY/360000.                                           
      T1=T1+TIME*ILT0/36000.                                            
      T2=T2+TIME*ILT1/36000.                                            
CX40108 CALL SBOUTX (108)                                               
CY40108 CALL SBOUTY (108)                                               
C                                                                       
      RETURN                                                            
      END                                                               
C                                                                       
C  *********************************************************************
C  *      SYNOPTIC WIND AND TEMPERATURE GENERATION   ROUTINE           *
C  *********************************************************************
C                                                                       
      SUBROUTINE UVSET(NX,NY,NZ,HVAR,ZET,NP,DZ,DKM,UM,VM,UG,VG,TM,      
     *WORK,ITY,IH,NSMT,F)                                               
      DIMENSION HVAR(*),ZET(*),TM(*),DKM(*),UM(*),VM(*),UG(*),VG(*),    
     *WORK(*)                                                           
      COMMON/STRCH/ALP,BET,DH,ZH,UGH,VGH,T1,T2,DT,TOL,ALPHA,HAMP,BUMP   
      COMMON/LAKE/SX,SIGX,SY,SIGY,ZNOT,SFX,SFY,FLX,FLY,BASE,TSL,H0,ZW,ZL
CX30109 CALL SBINX (109)                                                
CY30109 CALL SBINY (109)                                                
C                                                                       
C     IF THE FLOW IS TWO-DIMENSIONAL (X-Z) USE THE U PROFILE ONLY       
C     WHILE IF THE DIMENSIONS ARE (X,Y) USE THE GEOSTROPHIC WINDS       
C                                                                       
      L=2*NZ                                                            
C      L1=NZ                                                            
C ***  TRIDIAGONAL COMPLEX/REAL VECTOR AN, FOR CENTER ELEMENTS       ***
      LA=1                                                              
      LAST=L                                                            
C ***  TRIDIAGONAL COMPLEX/REAL VECTOR BN, FOR LEFT ELEMENTS         ***
      LB=LAST+1                                                         
      LAST=LAST+L                                                       
C ***  TRIDIAGONAL COMPLEX/REAL VECTOR CN, FOR RIGHT ELEMENTS        ***
      LC=LAST+1                                                         
      LAST=LAST+L                                                       
C ***  TRIDIAGONAL COMPLEX VECTOR FN, FOR FORCING                    ***
      LF=LAST+1                                                         
      LAST=LAST+L                                                       
C ***  COMPLEX MEAN WIND COMPONENT WM=UM+IVM                         ***
      LWM=LAST+1                                                        
      LAST=LAST+L                                                       
C ***  COMPLEX MEAN WIND COMPONENT WG=UG+IVG                         ***
      LWG=LAST+1                                                        
      LAST=LAST+L                                                       
C ***  DERIVATIVE OF DIFFUSSIVITY  DKZ                                  
C      VM WILL PLAY THE ROLE OF DKZ AND VECTOR DUMP                     
C      UM WILL BECOME A VECTOR FOR TESTING CONVERGENCE                  
C ***                                                                   
      CALL DINITU(ZET,TM,DKM,DZ,WORK(LWG),WORK(LWM),NZ,NP,UM,UG,VG,F)   
      ITER=0                                                            
      DNORM=0.0                                                         
C                                                                       
C     SOLVE FOR A NEW MEAN WIND PROFILE, AND THEN CORRECT THE MEAN      
C     TEMPERATURE PROFILE FOR MEAN HEAT AND MOMENTUM BALANCE.           
C                                                                       
 10   ITER=ITER+1                                                       
      IF(IH.EQ.0) THEN                                                  
         CALL CRANKC(DKM,VM,HVAR,WORK(LWM),WORK(LWG),                   
     *   WORK(LF),NZ,WORK(LA),WORK(LB),WORK(LC),ITY)                    
         CALL TMCRNK(DKM,HVAR,TM,VM,NZ,WORK(LA),WORK(LB),               
     *   WORK(LC),ITY)                                                  
                  ELSE                                                  
         CALL PADEC(DKM,VM,HVAR,WORK(LWM),WORK(LWG),                    
     *   WORK(LF),NZ,WORK(LA),WORK(LB),WORK(LC),ITY)                    
         CALL TMPADE(DKM,HVAR,TM,VM,NZ,WORK(LA),WORK(LB),               
     *   WORK(LC),ITY)                                                  
      ENDIF                                                             
C                                                                       
C     OBTAIN CORRECT DIFFUSSIVITIES                                     
C                                                                       
      CALL DKZMN(TM,WORK(LWM),ZET,DKM,DZ,ZNOT,USTAR,DL,KLAS,ZMH,F,NZ)   
      ITR=ITER                                                          
C                                                                       
C     CHECK FOR CONVERGENCE IN THE ITERATIONS                           
C                                                                       
      CALL TEST(UM,WORK(LWM),NZ,DNORM,ITER,TOL,DT,TIMEM)                
      IF(ITER.GT.29999)  THEN                                           
         CALL FINAL(NZ,UM,VM,UG,VG,TM,DKM,ZMH,DL,USTAR,KLAS,            
     *   WORK(LWM),ZET,DNORM,ITR,NY,DT,TIMEM)                           
C                                                                       
C     SMOOTH THE VERTICAL PROFILES IF NECESSARY                         
C                                                                       
         IF(NSMT.EQ.1) THEN                                             
            CALL SMTH(UM,ZET,NZ)                                        
            CALL SMTH(VM,ZET,NZ)                                        
         ENDIF                                                          
CX40110 CALL SBOUTX (110)                                               
CY40110 CALL SBOUTY (110)                                               
         RETURN                                                         
      ENDIF                                                             
      GOTO 10                                                           
      END                                                               
C                                                                       
C **********************************************************************
C *          INITIAL CONDITION FOR THE U AND V MEAN WIND COMPONENTS    *
C **********************************************************************
C                                                                       
      SUBROUTINE  DINITU(ZET,TM,DKM,DZ,WG,WM,NZ,NP,UM,UG,VG,F)          
      REAL ZET(1),TM(1),DKM(1),UM(1),UG(1),VG(1)                        
      COMPLEX WG(1),WM(1)                                               
      COMMON/LAKE/SX,SIGX,SY,SIGY,ZNOT,SFX,SFY,FLX,FLY,BASE,TSL,H0,ZW,ZL
      COMMON/STRCH/ALP,BET,DH,ZH,UGH,VGH,T1,T2,DUT,TOL,ALPHA,HAMP,BUMP  
      PARAMETER (PI = 3.141592653589793)                                
CX30111 CALL SBINX (111)                                                
CY30111 CALL SBINY (111)                                                
C                                                                       
C   WE DEFINE A NEW DZ FROM DZ=F*ZH*ZH/(2*PI*PI)                        
C                                                                       
      DZIN=F*ZH*ZH/(2*PI*PI)                                            
      GAMMA=SQRT(F/(2.0*DZIN))                                          
C                                                                       
C     CALCULATE THE MEAN TEMPERATURE AND PRESSURE GRADIENTS             
C                                                                       
      DTDZ=(T2-T1)/ZH                                                   
      DPDY=-F*UGH/T2                                                    
      DPDX= F*VGH/T2                                                    
      WG(1)=CMPLX(-T1*DPDY/F,T1*DPDX/F)                                 
C ***   LOWER BOUNDARY CONDITION ***                                    
      WM(1)=(0.0,0.0)                                                   
      TM(1)=T1                                                          
      UM(1)=0.                                                          
      UG(1)=-TM(1)*DPDY/F                                               
      VG(1)= TM(1)*DPDX/F                                               
CX10647 CALL DOINX( 647 )                                               
CY10647 CALL DOINY( 647 )                                               
      DO 10 K=2,NZ                                                      
         GZ=GAMMA*ZET(K)                                                
         EGZ=EXP(-GZ)                                                   
         TM(K)=T1+DTDZ*ZET(K)                                           
         UG(K)=-TM(K)*DPDY/F                                            
         VG(K)= TM(K)*DPDX/F                                            
         U0=UG(K)*(1.-COS(GZ)*EGZ)-VG(K)*SIN(GZ)*EGZ                    
         V0=VG(K)*(1.-COS(GZ)*EGZ)+UG(K)*SIN(GZ)*EGZ                    
         WG(K)=CMPLX(UG(K),VG(K))                                       
         WM(K)=CMPLX(U0,V0)                                             
         UM(K)=ABS(WM(K))                                               
 10   CONTINUE                                                          
CX20648 CALL DOOUTX( 648 )                                              
CY20648 CALL DOOUTY( 648 )                                              
C ***  UPPER BOUNDARY CONDITION                                         
      WM(NZ)=WG(NZ)                                                     
C ***  BOUNDARY LAYER SOLVER FOR FIRST DIFFUSIVITIES DZMIN->DKM         
      CALL DKZMN(TM,WM,ZET,DKM,DZ,ZNOT,USTAR,DL,KLAS,ZMH,F,NZ)          
CX40112 CALL SBOUTX (112)                                               
CY40112 CALL SBOUTY (112)                                               
C ***  DZ IS THE MINIMUM DIFFUSIVITY ASSIGNED IN THE BEGINING           
      RETURN                                                            
      END                                                               
C                                                                       
C **********************************************************************
C *            CONVERSION TO MEAN U,V COMPONENTS                       *
C **********************************************************************
C                                                                       
      SUBROUTINE FINAL(NZ,UM,VM,UG,VG,TM,DKM,ZMH,DL,USTAR,KLAS,WM,      
     *ZET,DNORM,ITR,NY,DT,TIMEM)                                        
      REAL UM(1),VM(1),TM(1),ZET(1),DKM(1),UG(1),VG(1)                  
      COMPLEX WM(1)                                                     
      COMMON/LAKE/SX,SIGX,SY,SIGY,ZNOT,SFX,SFY,FLX,FLY,BASE,TSL,H0,ZW,ZL
CX30113 CALL SBINX (113)                                                
CY30113 CALL SBINY (113)                                                
      WRITE(6,10) ITR,DNORM,TIMEM,ZNOT,ZMH,USTAR,KLAS,DL                
      WRITE(8,10) ITR,DNORM,TIMEM,ZNOT,ZMH,USTAR,KLAS,DL                
      WRITE(8,20)                                                       
      WRITE(6,20)                                                       
 10   FORMAT(/,                                                         
     *' ***********************  MEAN PROFILES ***********************' 
     *,//,' CONVERGENCE AFTER ',I6,' ITERATIONS.    NORM= ',E12.4,      
     */,' EQUIVALENT TIME FOR THE MEAN PROFILES  IS ',F10.2,' SEC. ',   
     */,' Z0=',F8.4,'   ZMIX=',F7.2,'   U*=',F9.5,'   L(',I1,')=',F12.2)
 20   FORMAT(//,'   K ',1X,'  HEIGHT (M)',6X,' UG(Z) ',3X,' VG(Z) '     
     *,4X,' TM(Z) ',4X,'  KM(Z)  ',4X,' UM(Z)  ',4X,' VM(Z)  ',/)       
CX10649 CALL DOINX( 649 )                                               
CY10649 CALL DOINY( 649 )                                               
      DO 30 K=1,NZ                                                      
         UM(K)=REAL(WM(K))                                              
         VM(K)=AIMAG(WM(K))                                             
         WRITE(6,40) K,ZET(K),UG(K),VG(K),TM(K),DKM(K),UM(K),VM(K)      
         WRITE(8,40) K,ZET(K),UG(K),VG(K),TM(K),DKM(K),UM(K),VM(K)      
 30   CONTINUE                                                          
CX20650 CALL DOOUTX( 650 )                                              
CY20650 CALL DOOUTY( 650 )                                              
 40   FORMAT(I4,F11.2,4X,2F10.2,4F12.2)                                 
      WRITE(6,50)                                                       
      WRITE(8,50)                                                       
 50   FORMAT(/,                                                         
     *' **************************************************************' 
     *,/)                                                               
CX40114 CALL SBOUTX (114)                                               
CY40114 CALL SBOUTY (114)                                               
      RETURN                                                            
      END                                                               
C                                                                       
C **********************************************************************
C *                     CONVERGENCE TEST ROUTINE                       *
C **********************************************************************
C                                                                       
      SUBROUTINE TEST(HELP,WM,NZ,DNORM,ITER,TOL,DT,TIMEM)               
      REAL HELP(1)                                                      
      COMPLEX WM(1)                                                     
CX30115 CALL SBINX (115)                                                
CY30115 CALL SBINY (115)                                                
C                                                                       
      TIMEM=ITER*DT                                                     
      DNORM=0.0                                                         
      IF(TOL.GT.1) THEN                                                 
         IF(TIMEM.GT.TOL) THEN                                          
            ITER=30000                                                  
CX40116 CALL SBOUTX (116)                                               
CY40116 CALL SBOUTY (116)                                               
            RETURN                                                      
         ENDIF                                                          
                   ELSE                                                 
CX10651 CALL DOINX( 651 )                                               
CY10651 CALL DOINY( 651 )                                               
         DO 10 K=1,NZ                                                   
            ZNEW=ABS(WM(K))                                             
            ZOLD=HELP(K)                                                
            HELP(K)=ZNEW                                                
            DNORM=DNORM+((ZNEW-ZOLD))**2/FLOAT(NZ)                      
 10      CONTINUE                                                       
CX20652 CALL DOOUTX( 652 )                                              
CY20652 CALL DOOUTY( 652 )                                              
         IF(DNORM.LT.TOL) ITER=30000                                    
      ENDIF                                                             
CX40116 CALL SBOUTX (116)                                               
CY40116 CALL SBOUTY (116)                                               
      RETURN                                                            
      END                                                               
C                                                                       
C **********************************************************************
C **              SET THE TOPOGRAPHY ELEV(I,J)                        **
C **     SET THE TOPOGRAPHY MATRIX, AND GRADIENTS OF TOPOGRRAPHY.     **
C **                                     < 0.0       WATER            **
C **      FOR  EVERY I,J: IF   ELEV(I,J) = 0.0  50% WATER, 50% LAND   **
C **                                     > 0.0       LAND             **
C **********************************************************************
C                                                                       
      SUBROUTINE TOPO(NX,NY,XSTART,YSTART,DELTAX,DELTAY,ELEV,ELEVX,     
     *ELEVY,Z0,HELP,HELPA,NX1,FX,FXX,FILX,SAVEX,NY1,FY,FYY,FILY,SAVEY)  
      REAL ELEV(1),ELEVX(1),ELEVY(1),Z0(1),FILX(1),FILY(1)              
      REAL HELP(1),HELPA(1),FX(1),FXX(1),SAVEX(1),FY(1),FYY(1),SAVEY(1) 
      COMMON/LAKE/SX,SIGX,SY,SIGY,ZNOT,SFX,SFY,FLX,FLY,BASE,TSL,H0,ZW,ZL
CX30117 CALL SBINX (117)                                                
CY30117 CALL SBINY (117)                                                
CGAO      PI=4.*ATAN(1.)                                                
      HIGH=0.0                                                          
      DLOW=0.0                                                          
CGAO      NXY=NX*NY                                                     
C                                                                       
C      NORMALLY READ THE TOPOGRAPHY AND ROUGNESS DATA FROM A FILE       
C      OPEN(21,FILE='TOPO.DAT')                                         
C      READ(21,10) (ELEV(L),L=1,NXY),(Z0(L),L=1,NXY)                    
C 10   FORMAT(NXF10.4)                                                  
C      OR PRODUCE THEM                                                  
C                                                                       
      IF(NX.EQ.1.AND.NY.EQ.1) THEN                                      
CX40118 CALL SBOUTX (118)                                               
CY40118 CALL SBOUTY (118)                                               
      RETURN                                                            
      ENDIF                                                             
      Y0=(YSTART+(NY-1)*DELTAY)/SY                                      
      X0=(XSTART+(NX-1)*DELTAX)/SX                                      
      YF0=(YSTART+(NY-1)*DELTAY)/SFY                                    
      XF0=(XSTART+(NX-1)*DELTAX)/SFX                                    
      IVEC=0                                                            
CX10653 CALL DOINX( 653 )                                               
CY10653 CALL DOINY( 653 )                                               
      DO 20 J=1,NY                                                      
         Y=YSTART+(J-1)*DELTAY                                          
         Y1=(Y-Y0)/SIGY                                                 
         YF1=(Y-YF0)/FLY                                                
         ARGFY=-YF1*YF1/2.                                              
         FILY(J)=EXP(ARGFY)                                             
         IF(FILY(J).GT.BASE) FILY(J)=BASE                               
         DO 10 I=1,NX                                                   
            IVEC=IVEC+1                                                 
            X=XSTART+(I-1)*DELTAX                                       
            X1=(X-X0)/SIGX                                              
            XF1=(X-XF0)/FLX                                             
            ARG=-X1*X1/2.-Y1*Y1/2.                                      
            ARGFX=-XF1*XF1/2.                                           
            FIELD=EXP(ARG)                                              
            FILX(I)=EXP(ARGFX)                                          
            IF(FILX(I).GT.BASE) FILX(I)=BASE                            
C     LAND POINTS                                                       
            IF(FIELD.LT.57) THEN                                        
               RUFNES=ZL                                                
               HEIGHT=1.0                                               
            ENDIF                                                       
C     MIXED POINTS                                                      
            IF(FIELD.GE.0.57.AND.FIELD.LT.0.6) THEN                     
                RUFNES=(ZL+ZW)/2.                                       
                HEIGHT=0.0                                              
            ENDIF                                                       
C     WATER POINTS                                                      
            IF(FIELD.GE.0.6) THEN                                       
               RUFNES=ZW                                                
               HEIGHT=-1.0                                              
            ENDIF                                                       
            Z0(IVEC)=RUFNES                                             
            ELEV(IVEC)=HEIGHT                                           
            HIGH=MAX(HIGH,HEIGHT)                                       
            DLOW=MIN(DLOW,HEIGHT)                                       
 10      CONTINUE                                                       
 20   CONTINUE                                                          
CX20654 CALL DOOUTX( 654 )                                              
CY20654 CALL DOOUTY( 654 )                                              
C                                                                       
C       CALCULATE TOPOGRAPHY GRADIENTS                                  
C                                                                       
      CALL DFTDX(NX,NY,NX1,ELEV,ELEVX,                                  
     *HELP,FX,SAVEX)                                                    
CX10655 CALL DOINX( 655 )                                               
CY10655 CALL DOINY( 655 )                                               
      DO 30 I=1,NX                                                      
         FILX(I)=FILX(I)/BASE                                           
 30   CONTINUE                                                          
CX20656 CALL DOOUTX( 656 )                                              
CY20656 CALL DOOUTY( 656 )                                              
      CALL FILTPR(FILX,NX,' X - FILTER ')                               
C                                                                       
      IF(NY.GT.1) THEN                                                  
         CALL DFTDY(NX,NY,NY1,ELEV,ELEVY,HELP,FY,SAVEY)                 
CX10657 CALL DOINX( 657 )                                               
CY10657 CALL DOINY( 657 )                                               
         DO 40 J=1,NY                                                   
            FILY(J)=FILY(J)/BASE                                        
 40      CONTINUE                                                       
CX20658 CALL DOOUTX( 658 )                                              
CY20658 CALL DOOUTY( 658 )                                              
         CALL FILTPR(FILY,NY,' Y - FILTER ')                            
      ENDIF                                                             
C                                                                       
C        PLOT TOPOGRAPHY                                                
C                                                                       
      CALL TOPPLT(NX,NY,HIGH,DLOW,ELEV)                                 
CX40118 CALL SBOUTX (118)                                               
CY40118 CALL SBOUTY (118)                                               
      RETURN                                                            
      END                                                               
C                                                                       
C **********************************************************************
C *                   PRINT THE  TOPOGRAPHY MAP                        *
C **********************************************************************
C                                                                       
       SUBROUTINE  TOPPLT(NX,NY,HIGH,DLOW,ELEV)                         
       REAL ELEV(NX,NY)                                                 
       CHARACTER MAP(128)                                               
 10    FORMAT(//10X,'  ****   TOPOGRAPHY  MAX = ',F10.2,' MIN = ',      
     * F10.2,'  METERS   ****',//)                                      
CX30119 CALL SBINX (119)                                                
CY30119 CALL SBINY (119)                                                
       WRITE(6,10) HIGH,DLOW                                            
       WRITE(8,10) HIGH,DLOW                                            
CX10659 CALL DOINX( 659 )                                               
CY10659 CALL DOINY( 659 )                                               
       DO 30 J=1,NY                                                     
          JJ=NY-J+1                                                     
          DO 20 I=1,NX                                                  
             IF(ELEV(I,JJ).LT.0.) MAP(I)='W'                            
             IF(ELEV(I,JJ).EQ.0.) MAP(I)='C'                            
             IF(ELEV(I,JJ).GT.0.) MAP(I)='L'                            
             IF(ELEV(I,JJ).GT.100.) MAP(I)='M'                          
 20       CONTINUE                                                      
          WRITE(6,40) (MAP(I),I=1,NX)                                   
          WRITE(8,40) (MAP(I),I=1,NX)                                   
 30    CONTINUE                                                         
CX20660 CALL DOOUTX( 660 )                                              
CY20660 CALL DOOUTY( 660 )                                              
 40    FORMAT(1X,64A,/,1X,64A,/1X,64A,/,1X,64A)                         
CX40120 CALL SBOUTX (120)                                               
CY40120 CALL SBOUTY (120)                                               
       RETURN                                                           
       END                                                              
C                                                                       
C **********************************************************************
C *    ROUTINE TO PRINT THE PRESSURE FILTER  SHAPE                     *
C **********************************************************************
C                                                                       
       SUBROUTINE FILTPR(FILT,N,LABEL)                                  
       REAL FILT(1)                                                     
       CHARACTER*12 LABEL                                               
       INTEGER MFILT(128)                                               
CX30121 CALL SBINX (121)                                                
CY30121 CALL SBINY (121)                                                
       WRITE(6,10) LABEL                                                
       WRITE(8,10) LABEL                                                
 10    FORMAT(/,' **************** ',A,' ***************** ',/)         
CX10661 CALL DOINX( 661 )                                               
CY10661 CALL DOINY( 661 )                                               
       DO 20 I=1,N                                                      
          MFILT(I)=10*FILT(I)                                           
          IF(MFILT(I).EQ.10) MFILT(I)=0                                 
 20    CONTINUE                                                         
CX20662 CALL DOOUTX( 662 )                                              
CY20662 CALL DOOUTY( 662 )                                              
       WRITE(6,30) (MFILT(I),I=1,N)                                     
       WRITE(8,30) (MFILT(I),I=1,N)                                     
 30    FORMAT(1X,64I1,/,1X,64I1,/1X,64I1,/,1X,64I1)                     
CX40122 CALL SBOUTX (122)                                               
CY40122 CALL SBOUTY (122)                                               
       RETURN                                                           
       END                                                              
C                                                                       
C  *********************************************************************
C  *                  ROUTINE TO PRINT THE MEAN PROFILES               *
C  *********************************************************************
C                                                                       
      SUBROUTINE PRN(NZ,UM,VM,TM,DKM,ZMH,DL,USTAR,KLAS,WM,              
     *ZET,DNORM,ITR)                                                    
      REAL UM(1),VM(1),TM(1),ZET(1),DKM(1)                              
      COMPLEX WM(1)                                                     
      COMMON/LAKE/SX,SIGX,SY,SIGY,ZNOT,SFX,SFY,FLX,FLY,BASE,TSL,H0,ZW,ZL
CX30123 CALL SBINX (123)                                                
CY30123 CALL SBINY (123)                                                
      WRITE(6,10) ITR,DNORM,ZNOT,ZMH,USTAR,KLAS,DL                      
      WRITE(8,10) ITR,DNORM,ZNOT,ZMH,USTAR,KLAS,DL                      
      WRITE(8,20)                                                       
      WRITE(6,20)                                                       
 10   FORMAT(/,'  CONVERGENCE AFTER ',I6,' ITERATIONS.    NORM= ',E12.4,
     */,' Z0=',F8.4,'   ZMIX=',F7.2,'   U*=',F9.5,'   L(',I1,')=',F12.2)
 20   FORMAT(//,'   K ',1X,'  HEIGHT (M)',6X,' UM(Z) ',3X,' VM(Z) '     
     *,4X,' TM(Z) ',4X,'  KM(Z)  ',/)                                   
CX10663 CALL DOINX( 663 )                                               
CY10663 CALL DOINY( 663 )                                               
      DO 30 K=1,NZ                                                      
         WRITE(6,40) K,ZET(K),WM(K),TM(K),DKM(K)                        
 30   CONTINUE                                                          
CX20664 CALL DOOUTX( 664 )                                              
CY20664 CALL DOOUTY( 664 )                                              
 40   FORMAT(I4,F11.2,4X,2F10.2,F12.2,F12.2)                            
CX40124 CALL SBOUTX (124)                                               
CY40124 CALL SBOUTY (124)                                               
      RETURN                                                            
      END                                                               
C                                                                       
C **********************************************************************
C *                 CPU  AND ELAPSE TIME MEASURES                      *
C **********************************************************************
C                                                                       
      SUBROUTINE CPUCLK(TM,INIT,RIT0)                                   
      REAL TMP0,TMP1                                                    
      SAVE TMP0                                                         
CX30125 CALL SBINX (125)                                                
CY30125 CALL SBINY (125)                                                
C                                                                       
       IF(INIT.EQ.0) THEN                                               
          CALL CPUTIM (TMP0)                                            
          TM=TMP0                                                       
       ENDIF                                                            
       CALL CPUTIM (TMP1)                                               
       TM=TMP1-TMP0                                                     
CX40126 CALL SBOUTX (126)                                               
CY40126 CALL SBOUTY (126)                                               
C                                                                       
       RETURN                                                           
       END                                                              
                                                                        
C                                                                       
C FFTPACKAGE FOR PSEUDOSPECTRAL ADVECTION CALCULATIONS   05/04/84       
C                                                                       
C PURPOSE  THIS PACKAGE CONSISTS OF PROGRAMS WHICH PERFORM FAST FOURIER 
C          TRANSFORMS FOR BOTH COMPLEX AND REAL PERIODIC SEQUENCES AND  
C          CERTIAN OTHER SYMMETRIC SEQUENCES THAT ARE LISTED BELOW.     
C                                                                       
C            RFFTI     INITIALIZE  RFFTF AND RFFTB                      
C            RFFTF     FORWARD TRANSFORM OF A REAL PERIODIC SEQUENCE    
C            RFFTB     BACKWARD TRANSFORM OF A REAL COEFFICIENT ARRAY   
C                                                                       
C     ******************************************************************
C                                                                       
C     SUBROUTINE RFFTI(N,WSAVE)                                         
C                                                                       
C     ******************************************************************
C                                                                       
C     SUBROUTINE RFFTI INITIALIZES THE ARRAY WSAVE WHICH IS USED IN     
C     BOTH RFFTF AND RFFTB. THE PRIME FACTORIZATION OF N TOGETHER WITH  
C     A TABULATION OF THE TRIGONOMETRIC FUNCTIONS ARE COMPUTED AND      
C     STORED IN WSAVE.                                                  
C                                                                       
C     INPUT PARAMETER                                                   
C                                                                       
C     N       THE LENGTH OF THE SEQUENCE TO BE TRANSFORMED.             
C                                                                       
C     OUTPUT PARAMETER                                                  
C                                                                       
C     WSAVE   A WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 2*N+15.   
C             THE SAME WORK ARRAY CAN BE USED FOR BOTH RFFTF AND RFFTB  
C             AS LONG AS N REMAINS UNCHANGED. DIFFERENT WSAVE ARRAYS    
C             ARE REQUIRED FOR DIFFERENT VALUES OF N. THE CONTENTS OF   
C             WSAVE MUST NOT BE CHANGED BETWEEN CALLS OF RFFTF OR RFFTB.
C                                                                       
C     ******************************************************************
C                                                                       
C     SUBROUTINE RFFTF(N,R,WSAVE)                                       
C                                                                       
C     ******************************************************************
C                                                                       
C     SUBROUTINE RFFTF COMPUTES THE FOURIER COEFFICIENTS OF A REAL      
C     PERODIC SEQUENCE (FOURIER ANALYSIS). THE TRANSFORM IS DEFINED     
C     BELOW AT OUTPUT PARAMETER R.                                      
C                                                                       
C     INPUT PARAMETERS                                                  
C                                                                       
C     N       THE LENGTH OF THE ARRAY R TO BE TRANSFORMED.  THE METHOD  
C             IS MOST EFFICIENT WHEN N IS A PRODUCT OF SMALL PRIMES.    
C             N MAY CHANGE SO LONG AS DIFFERENT WORK ARRAYS ARE PROVIDED
C                                                                       
C     R       A REAL ARRAY OF LENGTH N WHICH CONTAINS THE SEQUENCE      
C             TO BE TRANSFORMED                                         
C                                                                       
C     WSAVE   A WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 2*N+15.   
C             IN THE PROGRAM THAT CALLS RFFTF. THE WSAVE ARRAY MUST BE  
C             INITIALIZED BY CALLING SUBROUTINE RFFTI(N,WSAVE) AND A    
C             DIFFERENT WSAVE ARRAY MUST BE USED FOR EACH DIFFERENT     
C             VALUE OF N. THIS INITIALIZATION DOES NOT HAVE TO BE       
C             REPEATED SO LONG AS N REMAINS UNCHANGED THUS SUBSEQUENT   
C             TRANSFORMS CAN BE OBTAINED FASTER THAN THE FIRST.         
C             THE SAME WSAVE ARRAY CAN BE USED BY RFFTF AND RFFTB.      
C                                                                       
C                                                                       
C     OUTPUT PARAMETERS                                                 
C                                                                       
C     R       R(1) = THE SUM FROM I=1 TO I=N OF R(I)                    
C                                                                       
C             IF N IS EVEN SET L =N/2   , IF N IS ODD SET L = (N+1)/2   
C                                                                       
C               THEN FOR K = 2,...,L                                    
C                                                                       
C                  R(2*K-2) = THE SUM FROM I = 1 TO I = N OF            
C                                                                       
C                       R(I)*COS((K-1)*(I-1)*2*PI/N)                    
C                                                                       
C                  R(2*K-1) = THE SUM FROM I = 1 TO I = N OF            
C                                                                       
C                      -R(I)*SIN((K-1)*(I-1)*2*PI/N)                    
C                                                                       
C             IF N IS EVEN                                              
C                                                                       
C                  R(N) = THE SUM FROM I = 1 TO I = N OF                
C                                                                       
C                       (-1)**(I-1)*R(I)                                
C                                                                       
C      *****  NOTE                                                      
C                  THIS TRANSFORM IS UNNORMALIZED SINCE A CALL OF RFFTF 
C                  FOLLOWED BY A CALL OF RFFTB WILL MULTIPLY THE INPUT  
C                  SEQUENCE BY N.                                       
C                                                                       
C     WSAVE   CONTAINS RESULTS WHICH MUST NOT BE DESTROYED BETWEEN      
C             CALLS OF RFFTF OR RFFTB.                                  
C                                                                       
C                                                                       
C     ******************************************************************
C                                                                       
C     SUBROUTINE RFFTB(N,R,WSAVE)                                       
C                                                                       
C     ******************************************************************
C                                                                       
C     SUBROUTINE RFFTB COMPUTES THE REAL PERODIC SEQUENCE FROM ITS      
C     FOURIER COEFFICIENTS (FOURIER SYNTHESIS). THE TRANSFORM IS DEFINED
C     BELOW AT OUTPUT PARAMETER R.                                      
C                                                                       
C     INPUT PARAMETERS                                                  
C                                                                       
C     N       THE LENGTH OF THE ARRAY R TO BE TRANSFORMED.  THE METHOD  
C             IS MOST EFFICIENT WHEN N IS A PRODUCT OF SMALL PRIMES.    
C             N MAY CHANGE SO LONG AS DIFFERENT WORK ARRAYS ARE PROVIDED
C                                                                       
C     R       A REAL ARRAY OF LENGTH N WHICH CONTAINS THE SEQUENCE      
C             TO BE TRANSFORMED                                         
C                                                                       
C     WSAVE   A WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 2*N+15.   
C             IN THE PROGRAM THAT CALLS RFFTB. THE WSAVE ARRAY MUST BE  
C             INITIALIZED BY CALLING SUBROUTINE RFFTI(N,WSAVE) AND A    
C             DIFFERENT WSAVE ARRAY MUST BE USED FOR EACH DIFFERENT     
C             VALUE OF N. THIS INITIALIZATION DOES NOT HAVE TO BE       
C             REPEATED SO LONG AS N REMAINS UNCHANGED THUS SUBSEQUENT   
C             TRANSFORMS CAN BE OBTAINED FASTER THAN THE FIRST.         
C             THE SAME WSAVE ARRAY CAN BE USED BY RFFTF AND RFFTB.      
C                                                                       
C                                                                       
C     OUTPUT PARAMETERS                                                 
C                                                                       
C     R       FOR N EVEN AND FOR I = 1,...,N                            
C                                                                       
C                  R(I) = R(1)+(-1)**(I-1)*R(N)                         
C                                                                       
C                       PLUS THE SUM FROM K=2 TO K=N/2 OF               
C                                                                       
C                        2.*R(2*K-2)*COS((K-1)*(I-1)*2*PI/N)            
C                                                                       
C                       -2.*R(2*K-1)*SIN((K-1)*(I-1)*2*PI/N)            
C                                                                       
C             FOR N ODD AND FOR I = 1,...,N                             
C                                                                       
C                  R(I) = R(1) PLUS THE SUM FROM K=2 TO K=(N+1)/2 OF    
C                                                                       
C                       2.*R(2*K-2)*COS((K-1)*(I-1)*2*PI/N)             
C                                                                       
C                      -2.*R(2*K-1)*SIN((K-1)*(I-1)*2*PI/N)             
C                                                                       
C      *****  NOTE                                                      
C                  THIS TRANSFORM IS UNNORMALIZED SINCE A CALL OF RFFTF 
C                  FOLLOWED BY A CALL OF RFFTB WILL MULTIPLY THE INPUT  
C                  SEQUENCE BY N.                                       
C                                                                       
C     WSAVE   CONTAINS RESULTS WHICH MUST NOT BE DESTROYED BETWEEN      
C             CALLS OF RFFTB OR RFFTF.                                  
      SUBROUTINE RFFTI (N,WSAVE)                                        
      DIMENSION       WSAVE(*)                                          
CX30127 CALL SBINX (127)                                                
CY30127 CALL SBINY (127)                                                
      IF (N .EQ. 1) THEN                                                
CX40128 CALL SBOUTX (128)                                               
CY40128 CALL SBOUTY (128)                                               
      RETURN                                                            
      ENDIF                                                             
      CALL RFFTI1 (N,WSAVE(N+1),WSAVE(2*N+1))                           
CX40128 CALL SBOUTX (128)                                               
CY40128 CALL SBOUTY (128)                                               
      RETURN                                                            
      END                                                               
      SUBROUTINE COSTI (N,WSAVE)                                        
      DIMENSION       WSAVE(*)                                          
      PARAMETER (PI = 3.14159265358979)                                 
CX30129 CALL SBINX (129)                                                
CY30129 CALL SBINY (129)                                                
      IF (N .LE. 3) THEN                                                
CX40130 CALL SBOUTX (130)                                               
CY40130 CALL SBOUTY (130)                                               
      RETURN                                                            
      ENDIF                                                             
      NM1 = N-1                                                         
      NP1 = N+1                                                         
      NS2 = N/2                                                         
      DT = PI/FLOAT(NM1)                                                
      FK = 0.                                                           
CX10665 CALL DOINX( 665 )                                               
CY10665 CALL DOINY( 665 )                                               
      DO 101 K=2,NS2                                                    
         KC = NP1-K                                                     
         FK = FK+1.                                                     
         WSAVE(K) = 2.*SIN(FK*DT)                                       
         WSAVE(KC) = 2.*COS(FK*DT)                                      
  101 CONTINUE                                                          
CX20666 CALL DOOUTX( 666 )                                              
CY20666 CALL DOOUTY( 666 )                                              
      CALL RFFTI (NM1,WSAVE(N+1))                                       
CX40130 CALL SBOUTX (130)                                               
CY40130 CALL SBOUTY (130)                                               
      RETURN                                                            
      END                                                               
      SUBROUTINE COST (N,X,WSAVE)                                       
      DIMENSION       X(*)       ,WSAVE(*)                              
CX30131 CALL SBINX (131)                                                
CY30131 CALL SBINY (131)                                                
      NM1 = N-1                                                         
      NP1 = N+1                                                         
      NS2 = N/2                                                         
      IF (N-2) 106,101,102                                              
  101 X1H = X(1)+X(2)                                                   
      X(2) = X(1)-X(2)                                                  
      X(1) = X1H                                                        
CX40132 CALL SBOUTX (132)                                               
CY40132 CALL SBOUTY (132)                                               
      RETURN                                                            
  102 IF (N .GT. 3) GO TO 103                                           
      X1P3 = X(1)+X(3)                                                  
      TX2 = X(2)+X(2)                                                   
      X(2) = X(1)-X(3)                                                  
      X(1) = X1P3+TX2                                                   
      X(3) = X1P3-TX2                                                   
CX40132 CALL SBOUTX (132)                                               
CY40132 CALL SBOUTY (132)                                               
      RETURN                                                            
  103 C1 = X(1)-X(N)                                                    
      X(1) = X(1)+X(N)                                                  
CX10667 CALL DOINX( 667 )                                               
CY10667 CALL DOINY( 667 )                                               
      DO 104 K=2,NS2                                                    
         KC = NP1-K                                                     
         T1 = X(K)+X(KC)                                                
         T2 = X(K)-X(KC)                                                
         C1 = C1+WSAVE(KC)*T2                                           
         T2 = WSAVE(K)*T2                                               
         X(K) = T1-T2                                                   
         X(KC) = T1+T2                                                  
  104 CONTINUE                                                          
CX20668 CALL DOOUTX( 668 )                                              
CY20668 CALL DOOUTY( 668 )                                              
      MODN = MOD(N,2)                                                   
      IF (MODN .NE. 0) X(NS2+1) = X(NS2+1)+X(NS2+1)                     
      CALL RFFTF (NM1,X,WSAVE(N+1))                                     
      XIM2 = X(2)                                                       
      X(2) = C1                                                         
CX10669 CALL DOINX( 669 )                                               
CY10669 CALL DOINY( 669 )                                               
      DO 105 I=4,N,2                                                    
         XI = X(I)                                                      
         X(I) = X(I-2)-X(I-1)                                           
         X(I-1) = XIM2                                                  
         XIM2 = XI                                                      
  105 CONTINUE                                                          
CX20670 CALL DOOUTX( 670 )                                              
CY20670 CALL DOOUTY( 670 )                                              
      IF (MODN .NE. 0) X(N) = XIM2                                      
  106 CONTINUE                                                          
CX40132 CALL SBOUTX (132)                                               
CY40132 CALL SBOUTY (132)                                               
      RETURN                                                            
      END                                                               
                                                                        
      SUBROUTINE RFFTI1 (N,WA,IFAC)                                     
      DIMENSION  WA(*),IFAC(*),NTRYH(4)                                 
      SAVE NTRYH                                                        
      DATA NTRYH(1),NTRYH(2),NTRYH(3),NTRYH(4)/4,2,3,5/                 
CX30133 CALL SBINX (133)                                                
CY30133 CALL SBINY (133)                                                
      NL = N                                                            
      NF = 0                                                            
      J = 0                                                             
  101 J = J+1                                                           
      IF (J-4) 102,102,103                                              
  102 NTRY = NTRYH(J)                                                   
      GO TO 104                                                         
  103 NTRY = NTRY+2                                                     
  104 NQ = NL/NTRY                                                      
      NR = NL-NTRY*NQ                                                   
      IF (NR) 101,105,101                                               
  105 NF = NF+1                                                         
      IFAC(NF+2) = NTRY                                                 
      NL = NQ                                                           
      IF (NTRY .NE. 2) GO TO 107                                        
      IF (NF .EQ. 1) GO TO 107                                          
CX10671 CALL DOINX( 671 )                                               
CY10671 CALL DOINY( 671 )                                               
      DO 106 I=2,NF                                                     
         IB = NF-I+2                                                    
         IFAC(IB+2) = IFAC(IB+1)                                        
  106 CONTINUE                                                          
CX20672 CALL DOOUTX( 672 )                                              
CY20672 CALL DOOUTY( 672 )                                              
      IFAC(3) = 2                                                       
  107 IF (NL .NE. 1) GO TO 104                                          
      IFAC(1) = N                                                       
      IFAC(2) = NF                                                      
      TPI = 6.28318530717959                                            
      ARGH = TPI/FLOAT(N)                                               
      IS = 0                                                            
      NFM1 = NF-1                                                       
      L1 = 1                                                            
      IF (NFM1 .EQ. 0) THEN                                             
CX40134 CALL SBOUTX (134)                                               
CY40134 CALL SBOUTY (134)                                               
      RETURN                                                            
      ENDIF                                                             
CX10673 CALL DOINX( 673 )                                               
CY10673 CALL DOINY( 673 )                                               
      DO 110 K1=1,NFM1                                                  
         IP = IFAC(K1+2)                                                
         LD = 0                                                         
         L2 = L1*IP                                                     
         IDO = N/L2                                                     
         IPM = IP-1                                                     
         DO 109 J=1,IPM                                                 
            LD = LD+L1                                                  
            I = IS                                                      
            ARGLD = FLOAT(LD)*ARGH                                      
            FI = 0.                                                     
            DO 108 II=3,IDO,2                                           
               I = I+2                                                  
               FI = FI+1.                                               
               ARG = FI*ARGLD                                           
               WA(I-1) = COS(ARG)                                       
               WA(I) = SIN(ARG)                                         
  108       CONTINUE                                                    
            IS = IS+IDO                                                 
  109    CONTINUE                                                       
         L1 = L2                                                        
  110 CONTINUE                                                          
CX20674 CALL DOOUTX( 674 )                                              
CY20674 CALL DOOUTY( 674 )                                              
CX40134 CALL SBOUTX (134)                                               
CY40134 CALL SBOUTY (134)                                               
      RETURN                                                            
      END                                                               
      SUBROUTINE RFFTB (N,R,WSAVE)                                      
      DIMENSION       R(*)       ,WSAVE(*)                              
CX30135 CALL SBINX (135)                                                
CY30135 CALL SBINY (135)                                                
      IF (N .EQ. 1) THEN                                                
CX40136 CALL SBOUTX (136)                                               
CY40136 CALL SBOUTY (136)                                               
      RETURN                                                            
      ENDIF                                                             
      CALL RFFTB1 (N,R,WSAVE,WSAVE(N+1),WSAVE(2*N+1))                   
CX40136 CALL SBOUTX (136)                                               
CY40136 CALL SBOUTY (136)                                               
      RETURN                                                            
      END                                                               
      SUBROUTINE RFFTB1 (N,C,CH,WA,IFAC)                                
      DIMENSION       CH(*)      ,C(*)       ,WA(*)      ,IFAC(*)       
CX30137 CALL SBINX (137)                                                
CY30137 CALL SBINY (137)                                                
      NF = IFAC(2)                                                      
      NA = 0                                                            
      L1 = 1                                                            
      IW = 1                                                            
CX10675 CALL DOINX( 675 )                                               
CY10675 CALL DOINY( 675 )                                               
      DO 116 K1=1,NF                                                    
         IP = IFAC(K1+2)                                                
         L2 = IP*L1                                                     
         IDO = N/L2                                                     
         IDL1 = IDO*L1                                                  
         IF (IP .NE. 4) GO TO 103                                       
         IX2 = IW+IDO                                                   
         IX3 = IX2+IDO                                                  
         IF (NA .NE. 0) GO TO 101                                       
         CALL RADB4 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3))                
         GO TO 102                                                      
  101    CALL RADB4 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3))                
  102    NA = 1-NA                                                      
         GO TO 115                                                      
  103    IF (IP .NE. 2) GO TO 106                                       
         IF (NA .NE. 0) GO TO 104                                       
         CALL RADB2 (IDO,L1,C,CH,WA(IW))                                
         GO TO 105                                                      
  104    CALL RADB2 (IDO,L1,CH,C,WA(IW))                                
  105    NA = 1-NA                                                      
         GO TO 115                                                      
  106    IF (IP .NE. 3) GO TO 109                                       
         IX2 = IW+IDO                                                   
         IF (NA .NE. 0) GO TO 107                                       
         CALL RADB3 (IDO,L1,C,CH,WA(IW),WA(IX2))                        
         GO TO 108                                                      
  107    CALL RADB3 (IDO,L1,CH,C,WA(IW),WA(IX2))                        
  108    NA = 1-NA                                                      
         GO TO 115                                                      
  109    IF (IP .NE. 5) GO TO 112                                       
         IX2 = IW+IDO                                                   
         IX3 = IX2+IDO                                                  
         IX4 = IX3+IDO                                                  
         IF (NA .NE. 0) GO TO 110                                       
         CALL RADB5 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4))        
         GO TO 111                                                      
  110    CALL RADB5 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4))        
  111    NA = 1-NA                                                      
         GO TO 115                                                      
  112    IF (NA .NE. 0) GO TO 113                                       
         CALL RADBG (IDO,IP,L1,IDL1,C,C,C,CH,CH,WA(IW))                 
         GO TO 114                                                      
  113    CALL RADBG (IDO,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW))                
  114    IF (IDO .EQ. 1) NA = 1-NA                                      
  115    L1 = L2                                                        
         IW = IW+(IP-1)*IDO                                             
  116 CONTINUE                                                          
CX20676 CALL DOOUTX( 676 )                                              
CY20676 CALL DOOUTY( 676 )                                              
      IF (NA .EQ. 0) THEN                                               
CX40138 CALL SBOUTX (138)                                               
CY40138 CALL SBOUTY (138)                                               
      RETURN                                                            
      ENDIF                                                             
CX10677 CALL DOINX( 677 )                                               
CY10677 CALL DOINY( 677 )                                               
      DO 117 I=1,N                                                      
         C(I) = CH(I)                                                   
  117 CONTINUE                                                          
CX20678 CALL DOOUTX( 678 )                                              
CY20678 CALL DOOUTY( 678 )                                              
CX40138 CALL SBOUTX (138)                                               
CY40138 CALL SBOUTY (138)                                               
      RETURN                                                            
      END                                                               
      SUBROUTINE RADB2 (IDO,L1,CC,CH,WA1)                               
      DIMENSION       CC(IDO,2,L1)           ,CH(IDO,L1,2)           ,  
     1                WA1(*)                                            
CX30139 CALL SBINX (139)                                                
CY30139 CALL SBINY (139)                                                
CX10679 CALL DOINX( 679 )                                               
CY10679 CALL DOINY( 679 )                                               
      DO 101 K=1,L1                                                     
         CH(1,K,1) = CC(1,1,K)+CC(IDO,2,K)                              
         CH(1,K,2) = CC(1,1,K)-CC(IDO,2,K)                              
  101 CONTINUE                                                          
CX20680 CALL DOOUTX( 680 )                                              
CY20680 CALL DOOUTY( 680 )                                              
      IF (IDO-2) 107,105,102                                            
  102 IDP2 = IDO+2                                                      
CX10681 CALL DOINX( 681 )                                               
CY10681 CALL DOINY( 681 )                                               
      DO 104 K=1,L1                                                     
         DO 103 I=3,IDO,2                                               
            IC = IDP2-I                                                 
            CH(I-1,K,1) = CC(I-1,1,K)+CC(IC-1,2,K)                      
            TR2 = CC(I-1,1,K)-CC(IC-1,2,K)                              
            CH(I,K,1) = CC(I,1,K)-CC(IC,2,K)                            
            TI2 = CC(I,1,K)+CC(IC,2,K)                                  
            CH(I-1,K,2) = WA1(I-2)*TR2-WA1(I-1)*TI2                     
            CH(I,K,2) = WA1(I-2)*TI2+WA1(I-1)*TR2                       
  103    CONTINUE                                                       
  104 CONTINUE                                                          
CX20682 CALL DOOUTX( 682 )                                              
CY20682 CALL DOOUTY( 682 )                                              
      IF (MOD(IDO,2) .EQ. 1) THEN                                       
CX40140 CALL SBOUTX (140)                                               
CY40140 CALL SBOUTY (140)                                               
      RETURN                                                            
      ENDIF                                                             
  105 CONTINUE                                                          
CX10683 CALL DOINX( 683 )                                               
CY10683 CALL DOINY( 683 )                                               
      DO      106      K=1,L1                                           
         CH(IDO,K,1) = CC(IDO,1,K)+CC(IDO,1,K)                          
         CH(IDO,K,2) = -(CC(1,2,K)+CC(1,2,K))                           
  106 CONTINUE                                                          
CX20684 CALL DOOUTX( 684 )                                              
CY20684 CALL DOOUTY( 684 )                                              
  107 CONTINUE                                                          
CX40140 CALL SBOUTX (140)                                               
CY40140 CALL SBOUTY (140)                                               
      RETURN                                                            
      END                                                               
      SUBROUTINE RADB3 (IDO,L1,CC,CH,WA1,WA2)                           
      DIMENSION       CC(IDO,3,L1)           ,CH(IDO,L1,3)           ,  
     1                WA1(*)     ,WA2(*)                                
      PARAMETER (TAUR = -.5, TAUI = .866025403784439)                   
CX30141 CALL SBINX (141)                                                
CY30141 CALL SBINY (141)                                                
CX10685 CALL DOINX( 685 )                                               
CY10685 CALL DOINY( 685 )                                               
      DO 101 K=1,L1                                                     
         TR2 = CC(IDO,2,K)+CC(IDO,2,K)                                  
         CR2 = CC(1,1,K)+TAUR*TR2                                       
         CH(1,K,1) = CC(1,1,K)+TR2                                      
         CI3 = TAUI*(CC(1,3,K)+CC(1,3,K))                               
         CH(1,K,2) = CR2-CI3                                            
         CH(1,K,3) = CR2+CI3                                            
  101 CONTINUE                                                          
CX20686 CALL DOOUTX( 686 )                                              
CY20686 CALL DOOUTY( 686 )                                              
      IF (IDO .EQ. 1) THEN                                              
CX40142 CALL SBOUTX (142)                                               
CY40142 CALL SBOUTY (142)                                               
      RETURN                                                            
      ENDIF                                                             
      IDP2 = IDO+2                                                      
CX10687 CALL DOINX( 687 )                                               
CY10687 CALL DOINY( 687 )                                               
      DO 103 K=1,L1                                                     
         DO 102 I=3,IDO,2                                               
            IC = IDP2-I                                                 
            TR2 = CC(I-1,3,K)+CC(IC-1,2,K)                              
            CR2 = CC(I-1,1,K)+TAUR*TR2                                  
            CH(I-1,K,1) = CC(I-1,1,K)+TR2                               
            TI2 = CC(I,3,K)-CC(IC,2,K)                                  
            CI2 = CC(I,1,K)+TAUR*TI2                                    
            CH(I,K,1) = CC(I,1,K)+TI2                                   
            CR3 = TAUI*(CC(I-1,3,K)-CC(IC-1,2,K))                       
            CI3 = TAUI*(CC(I,3,K)+CC(IC,2,K))                           
            DR2 = CR2-CI3                                               
            DR3 = CR2+CI3                                               
            DI2 = CI2+CR3                                               
            DI3 = CI2-CR3                                               
            CH(I-1,K,2) = WA1(I-2)*DR2-WA1(I-1)*DI2                     
            CH(I,K,2) = WA1(I-2)*DI2+WA1(I-1)*DR2                       
            CH(I-1,K,3) = WA2(I-2)*DR3-WA2(I-1)*DI3                     
            CH(I,K,3) = WA2(I-2)*DI3+WA2(I-1)*DR3                       
  102    CONTINUE                                                       
  103 CONTINUE                                                          
CX20688 CALL DOOUTX( 688 )                                              
CY20688 CALL DOOUTY( 688 )                                              
CX40142 CALL SBOUTX (142)                                               
CY40142 CALL SBOUTY (142)                                               
      RETURN                                                            
      END                                                               
      SUBROUTINE RADB4 (IDO,L1,CC,CH,WA1,WA2,WA3)                       
      DIMENSION       CC(IDO,4,L1)           ,CH(IDO,L1,4)           ,  
     1                WA1(*)     ,WA2(*)     ,WA3(*)                    
      PARAMETER (SQRT2 = 1.414213562373095)                             
CX30143 CALL SBINX (143)                                                
CY30143 CALL SBINY (143)                                                
CX10689 CALL DOINX( 689 )                                               
CY10689 CALL DOINY( 689 )                                               
      DO 101 K=1,L1                                                     
         TR1 = CC(1,1,K)-CC(IDO,4,K)                                    
         TR2 = CC(1,1,K)+CC(IDO,4,K)                                    
         TR3 = CC(IDO,2,K)+CC(IDO,2,K)                                  
         TR4 = CC(1,3,K)+CC(1,3,K)                                      
         CH(1,K,1) = TR2+TR3                                            
         CH(1,K,2) = TR1-TR4                                            
         CH(1,K,3) = TR2-TR3                                            
         CH(1,K,4) = TR1+TR4                                            
  101 CONTINUE                                                          
CX20690 CALL DOOUTX( 690 )                                              
CY20690 CALL DOOUTY( 690 )                                              
      IF (IDO-2) 107,105,102                                            
  102 IDP2 = IDO+2                                                      
CX10691 CALL DOINX( 691 )                                               
CY10691 CALL DOINY( 691 )                                               
      DO 104 K=1,L1                                                     
         DO 103 I=3,IDO,2                                               
            IC = IDP2-I                                                 
            TI1 = CC(I,1,K)+CC(IC,4,K)                                  
            TI2 = CC(I,1,K)-CC(IC,4,K)                                  
            TI3 = CC(I,3,K)-CC(IC,2,K)                                  
            TR4 = CC(I,3,K)+CC(IC,2,K)                                  
            TR1 = CC(I-1,1,K)-CC(IC-1,4,K)                              
            TR2 = CC(I-1,1,K)+CC(IC-1,4,K)                              
            TI4 = CC(I-1,3,K)-CC(IC-1,2,K)                              
            TR3 = CC(I-1,3,K)+CC(IC-1,2,K)                              
            CH(I-1,K,1) = TR2+TR3                                       
            CR3 = TR2-TR3                                               
            CH(I,K,1) = TI2+TI3                                         
            CI3 = TI2-TI3                                               
            CR2 = TR1-TR4                                               
            CR4 = TR1+TR4                                               
            CI2 = TI1+TI4                                               
            CI4 = TI1-TI4                                               
            CH(I-1,K,2) = WA1(I-2)*CR2-WA1(I-1)*CI2                     
            CH(I,K,2) = WA1(I-2)*CI2+WA1(I-1)*CR2                       
            CH(I-1,K,3) = WA2(I-2)*CR3-WA2(I-1)*CI3                     
            CH(I,K,3) = WA2(I-2)*CI3+WA2(I-1)*CR3                       
            CH(I-1,K,4) = WA3(I-2)*CR4-WA3(I-1)*CI4                     
            CH(I,K,4) = WA3(I-2)*CI4+WA3(I-1)*CR4                       
  103    CONTINUE                                                       
  104 CONTINUE                                                          
CX20692 CALL DOOUTX( 692 )                                              
CY20692 CALL DOOUTY( 692 )                                              
      IF (MOD(IDO,2) .EQ. 1) THEN                                       
CX40144 CALL SBOUTX (144)                                               
CY40144 CALL SBOUTY (144)                                               
      RETURN                                                            
      ENDIF                                                             
  105 CONTINUE                                                          
CX10693 CALL DOINX( 693 )                                               
CY10693 CALL DOINY( 693 )                                               
      DO 106 K=1,L1                                                     
         TI1 = CC(1,2,K)+CC(1,4,K)                                      
         TI2 = CC(1,4,K)-CC(1,2,K)                                      
         TR1 = CC(IDO,1,K)-CC(IDO,3,K)                                  
         TR2 = CC(IDO,1,K)+CC(IDO,3,K)                                  
         CH(IDO,K,1) = TR2+TR2                                          
         CH(IDO,K,2) = SQRT2*(TR1-TI1)                                  
         CH(IDO,K,3) = TI2+TI2                                          
         CH(IDO,K,4) = -SQRT2*(TR1+TI1)                                 
  106 CONTINUE                                                          
CX20694 CALL DOOUTX( 694 )                                              
CY20694 CALL DOOUTY( 694 )                                              
  107 CONTINUE                                                          
CX40144 CALL SBOUTX (144)                                               
CY40144 CALL SBOUTY (144)                                               
      RETURN                                                            
      END                                                               
      SUBROUTINE RADB5 (IDO,L1,CC,CH,WA1,WA2,WA3,WA4)                   
      DIMENSION       CC(IDO,5,L1)           ,CH(IDO,L1,5)           ,  
     1                WA1(*)     ,WA2(*)     ,WA3(*)     ,WA4(*)        
      PARAMETER (TR11 = .309016994374947, TI11 = .951056516295154,      
     *           TR12 = -.809016994374947, TI12 = .587785252292473)     
CX30145 CALL SBINX (145)                                                
CY30145 CALL SBINY (145)                                                
CX10695 CALL DOINX( 695 )                                               
CY10695 CALL DOINY( 695 )                                               
      DO 101 K=1,L1                                                     
         TI5 = CC(1,3,K)+CC(1,3,K)                                      
         TI4 = CC(1,5,K)+CC(1,5,K)                                      
         TR2 = CC(IDO,2,K)+CC(IDO,2,K)                                  
         TR3 = CC(IDO,4,K)+CC(IDO,4,K)                                  
         CH(1,K,1) = CC(1,1,K)+TR2+TR3                                  
         CR2 = CC(1,1,K)+TR11*TR2+TR12*TR3                              
         CR3 = CC(1,1,K)+TR12*TR2+TR11*TR3                              
         CI5 = TI11*TI5+TI12*TI4                                        
         CI4 = TI12*TI5-TI11*TI4                                        
         CH(1,K,2) = CR2-CI5                                            
         CH(1,K,3) = CR3-CI4                                            
         CH(1,K,4) = CR3+CI4                                            
         CH(1,K,5) = CR2+CI5                                            
  101 CONTINUE                                                          
CX20696 CALL DOOUTX( 696 )                                              
CY20696 CALL DOOUTY( 696 )                                              
      IF (IDO .EQ. 1) THEN                                              
CX40146 CALL SBOUTX (146)                                               
CY40146 CALL SBOUTY (146)                                               
      RETURN                                                            
      ENDIF                                                             
      IDP2 = IDO+2                                                      
CX10697 CALL DOINX( 697 )                                               
CY10697 CALL DOINY( 697 )                                               
      DO 103 K=1,L1                                                     
         DO 102 I=3,IDO,2                                               
            IC = IDP2-I                                                 
            TI5 = CC(I,3,K)+CC(IC,2,K)                                  
            TI2 = CC(I,3,K)-CC(IC,2,K)                                  
            TI4 = CC(I,5,K)+CC(IC,4,K)                                  
            TI3 = CC(I,5,K)-CC(IC,4,K)                                  
            TR5 = CC(I-1,3,K)-CC(IC-1,2,K)                              
            TR2 = CC(I-1,3,K)+CC(IC-1,2,K)                              
            TR4 = CC(I-1,5,K)-CC(IC-1,4,K)                              
            TR3 = CC(I-1,5,K)+CC(IC-1,4,K)                              
            CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3                           
            CH(I,K,1) = CC(I,1,K)+TI2+TI3                               
            CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3                         
            CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3                           
            CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3                         
            CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3                           
            CR5 = TI11*TR5+TI12*TR4                                     
            CI5 = TI11*TI5+TI12*TI4                                     
            CR4 = TI12*TR5-TI11*TR4                                     
            CI4 = TI12*TI5-TI11*TI4                                     
            DR3 = CR3-CI4                                               
            DR4 = CR3+CI4                                               
            DI3 = CI3+CR4                                               
            DI4 = CI3-CR4                                               
            DR5 = CR2+CI5                                               
            DR2 = CR2-CI5                                               
            DI5 = CI2-CR5                                               
            DI2 = CI2+CR5                                               
            CH(I-1,K,2) = WA1(I-2)*DR2-WA1(I-1)*DI2                     
            CH(I,K,2) = WA1(I-2)*DI2+WA1(I-1)*DR2                       
            CH(I-1,K,3) = WA2(I-2)*DR3-WA2(I-1)*DI3                     
            CH(I,K,3) = WA2(I-2)*DI3+WA2(I-1)*DR3                       
            CH(I-1,K,4) = WA3(I-2)*DR4-WA3(I-1)*DI4                     
            CH(I,K,4) = WA3(I-2)*DI4+WA3(I-1)*DR4                       
            CH(I-1,K,5) = WA4(I-2)*DR5-WA4(I-1)*DI5                     
            CH(I,K,5) = WA4(I-2)*DI5+WA4(I-1)*DR5                       
  102    CONTINUE                                                       
  103 CONTINUE                                                          
CX20698 CALL DOOUTX( 698 )                                              
CY20698 CALL DOOUTY( 698 )                                              
CX40146 CALL SBOUTX (146)                                               
CY40146 CALL SBOUTY (146)                                               
      RETURN                                                            
      END                                                               
      SUBROUTINE RADBG (IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA)              
      DIMENSION       CH(IDO,L1,IP)          ,CC(IDO,IP,L1)          ,  
     1                C1(IDO,L1,IP)          ,C2(IDL1,IP),              
     2                CH2(IDL1,IP)           ,WA(*)                     
      PARAMETER (TPI = 6.28318530717959)                                
CX30147 CALL SBINX (147)                                                
CY30147 CALL SBINY (147)                                                
      ARG = TPI/FLOAT(IP)                                               
      DCP = COS(ARG)                                                    
      DSP = SIN(ARG)                                                    
      IDP2 = IDO+2                                                      
      NBD = (IDO-1)/2                                                   
      IPP2 = IP+2                                                       
      IPPH = (IP+1)/2                                                   
      IF (IDO .LT. L1) GO TO 103                                        
CX10699 CALL DOINX( 699 )                                               
CY10699 CALL DOINY( 699 )                                               
      DO 102 K=1,L1                                                     
         DO 101 I=1,IDO                                                 
            CH(I,K,1) = CC(I,1,K)                                       
  101    CONTINUE                                                       
  102 CONTINUE                                                          
CX20700 CALL DOOUTX( 700 )                                              
CY20700 CALL DOOUTY( 700 )                                              
      GO TO 106                                                         
  103 CONTINUE                                                          
CX10701 CALL DOINX( 701 )                                               
CY10701 CALL DOINY( 701 )                                               
      DO      105      I=1,IDO                                          
         DO 104 K=1,L1                                                  
            CH(I,K,1) = CC(I,1,K)                                       
  104    CONTINUE                                                       
  105 CONTINUE                                                          
CX20702 CALL DOOUTX( 702 )                                              
CY20702 CALL DOOUTY( 702 )                                              
  106 CONTINUE                                                          
CX10703 CALL DOINX( 703 )                                               
CY10703 CALL DOINY( 703 )                                               
      DO      108      J=2,IPPH                                         
         JC = IPP2-J                                                    
         J2 = J+J                                                       
         DO 107 K=1,L1                                                  
            CH(1,K,J) = CC(IDO,J2-2,K)+CC(IDO,J2-2,K)                   
            CH(1,K,JC) = CC(1,J2-1,K)+CC(1,J2-1,K)                      
  107    CONTINUE                                                       
  108 CONTINUE                                                          
CX20704 CALL DOOUTX( 704 )                                              
CY20704 CALL DOOUTY( 704 )                                              
      IF (IDO .EQ. 1) GO TO 116                                         
      IF (NBD .LT. L1) GO TO 112                                        
CX10705 CALL DOINX( 705 )                                               
CY10705 CALL DOINY( 705 )                                               
      DO 111 J=2,IPPH                                                   
         JC = IPP2-J                                                    
         DO 110 K=1,L1                                                  
            DO 109 I=3,IDO,2                                            
               IC = IDP2-I                                              
               CH(I-1,K,J) = CC(I-1,2*J-1,K)+CC(IC-1,2*J-2,K)           
               CH(I-1,K,JC) = CC(I-1,2*J-1,K)-CC(IC-1,2*J-2,K)          
               CH(I,K,J) = CC(I,2*J-1,K)-CC(IC,2*J-2,K)                 
               CH(I,K,JC) = CC(I,2*J-1,K)+CC(IC,2*J-2,K)                
  109       CONTINUE                                                    
  110    CONTINUE                                                       
  111 CONTINUE                                                          
CX20706 CALL DOOUTX( 706 )                                              
CY20706 CALL DOOUTY( 706 )                                              
      GO TO 116                                                         
  112 CONTINUE                                                          
CX10707 CALL DOINX( 707 )                                               
CY10707 CALL DOINY( 707 )                                               
      DO      115      J=2,IPPH                                         
         JC = IPP2-J                                                    
         DO 114 I=3,IDO,2                                               
            IC = IDP2-I                                                 
            DO 113 K=1,L1                                               
               CH(I-1,K,J) = CC(I-1,2*J-1,K)+CC(IC-1,2*J-2,K)           
               CH(I-1,K,JC) = CC(I-1,2*J-1,K)-CC(IC-1,2*J-2,K)          
               CH(I,K,J) = CC(I,2*J-1,K)-CC(IC,2*J-2,K)                 
               CH(I,K,JC) = CC(I,2*J-1,K)+CC(IC,2*J-2,K)                
  113       CONTINUE                                                    
  114    CONTINUE                                                       
  115 CONTINUE                                                          
CX20708 CALL DOOUTX( 708 )                                              
CY20708 CALL DOOUTY( 708 )                                              
  116 AR1 = 1.                                                          
      AI1 = 0.                                                          
CX10709 CALL DOINX( 709 )                                               
CY10709 CALL DOINY( 709 )                                               
      DO 120 L=2,IPPH                                                   
         LC = IPP2-L                                                    
         AR1H = DCP*AR1-DSP*AI1                                         
         AI1 = DCP*AI1+DSP*AR1                                          
         AR1 = AR1H                                                     
         DO 117 IK=1,IDL1                                               
            C2(IK,L) = CH2(IK,1)+AR1*CH2(IK,2)                          
            C2(IK,LC) = AI1*CH2(IK,IP)                                  
  117    CONTINUE                                                       
         DC2 = AR1                                                      
         DS2 = AI1                                                      
         AR2 = AR1                                                      
         AI2 = AI1                                                      
         DO 119 J=3,IPPH                                                
            JC = IPP2-J                                                 
            AR2H = DC2*AR2-DS2*AI2                                      
            AI2 = DC2*AI2+DS2*AR2                                       
            AR2 = AR2H                                                  
            DO 118 IK=1,IDL1                                            
               C2(IK,L) = C2(IK,L)+AR2*CH2(IK,J)                        
               C2(IK,LC) = C2(IK,LC)+AI2*CH2(IK,JC)                     
  118       CONTINUE                                                    
  119    CONTINUE                                                       
  120 CONTINUE                                                          
CX20710 CALL DOOUTX( 710 )                                              
CY20710 CALL DOOUTY( 710 )                                              
CX10711 CALL DOINX( 711 )                                               
CY10711 CALL DOINY( 711 )                                               
      DO 122 J=2,IPPH                                                   
         DO 121 IK=1,IDL1                                               
            CH2(IK,1) = CH2(IK,1)+CH2(IK,J)                             
  121    CONTINUE                                                       
  122 CONTINUE                                                          
CX20712 CALL DOOUTX( 712 )                                              
CY20712 CALL DOOUTY( 712 )                                              
CX10713 CALL DOINX( 713 )                                               
CY10713 CALL DOINY( 713 )                                               
      DO 124 J=2,IPPH                                                   
         JC = IPP2-J                                                    
         DO 123 K=1,L1                                                  
            CH(1,K,J) = C1(1,K,J)-C1(1,K,JC)                            
            CH(1,K,JC) = C1(1,K,J)+C1(1,K,JC)                           
  123    CONTINUE                                                       
  124 CONTINUE                                                          
CX20714 CALL DOOUTX( 714 )                                              
CY20714 CALL DOOUTY( 714 )                                              
      IF (IDO .EQ. 1) GO TO 132                                         
      IF (NBD .LT. L1) GO TO 128                                        
CX10715 CALL DOINX( 715 )                                               
CY10715 CALL DOINY( 715 )                                               
      DO 127 J=2,IPPH                                                   
         JC = IPP2-J                                                    
         DO 126 K=1,L1                                                  
            DO 125 I=3,IDO,2                                            
               CH(I-1,K,J) = C1(I-1,K,J)-C1(I,K,JC)                     
               CH(I-1,K,JC) = C1(I-1,K,J)+C1(I,K,JC)                    
               CH(I,K,J) = C1(I,K,J)+C1(I-1,K,JC)                       
               CH(I,K,JC) = C1(I,K,J)-C1(I-1,K,JC)                      
  125       CONTINUE                                                    
  126    CONTINUE                                                       
  127 CONTINUE                                                          
CX20716 CALL DOOUTX( 716 )                                              
CY20716 CALL DOOUTY( 716 )                                              
      GO TO 132                                                         
  128 CONTINUE                                                          
CX10717 CALL DOINX( 717 )                                               
CY10717 CALL DOINY( 717 )                                               
      DO      131      J=2,IPPH                                         
         JC = IPP2-J                                                    
         DO 130 I=3,IDO,2                                               
            DO 129 K=1,L1                                               
               CH(I-1,K,J) = C1(I-1,K,J)-C1(I,K,JC)                     
               CH(I-1,K,JC) = C1(I-1,K,J)+C1(I,K,JC)                    
               CH(I,K,J) = C1(I,K,J)+C1(I-1,K,JC)                       
               CH(I,K,JC) = C1(I,K,J)-C1(I-1,K,JC)                      
  129       CONTINUE                                                    
  130    CONTINUE                                                       
  131 CONTINUE                                                          
CX20718 CALL DOOUTX( 718 )                                              
CY20718 CALL DOOUTY( 718 )                                              
  132 CONTINUE                                                          
      IF (IDO .EQ. 1) THEN                                              
CX40148 CALL SBOUTX (148)                                               
CY40148 CALL SBOUTY (148)                                               
      RETURN                                                            
      ENDIF                                                             
CX10719 CALL DOINX( 719 )                                               
CY10719 CALL DOINY( 719 )                                               
      DO 133 IK=1,IDL1                                                  
         C2(IK,1) = CH2(IK,1)                                           
  133 CONTINUE                                                          
CX20720 CALL DOOUTX( 720 )                                              
CY20720 CALL DOOUTY( 720 )                                              
CX10721 CALL DOINX( 721 )                                               
CY10721 CALL DOINY( 721 )                                               
      DO 135 J=2,IP                                                     
         DO 134 K=1,L1                                                  
            C1(1,K,J) = CH(1,K,J)                                       
  134    CONTINUE                                                       
  135 CONTINUE                                                          
CX20722 CALL DOOUTX( 722 )                                              
CY20722 CALL DOOUTY( 722 )                                              
      IF (NBD .GT. L1) GO TO 139                                        
      IS = -IDO                                                         
CX10723 CALL DOINX( 723 )                                               
CY10723 CALL DOINY( 723 )                                               
      DO 138 J=2,IP                                                     
         IS = IS+IDO                                                    
         IDIJ = IS                                                      
         DO 137 I=3,IDO,2                                               
            IDIJ = IDIJ+2                                               
            DO 136 K=1,L1                                               
               C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J)  
               C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J)    
  136       CONTINUE                                                    
  137    CONTINUE                                                       
  138 CONTINUE                                                          
CX20724 CALL DOOUTX( 724 )                                              
CY20724 CALL DOOUTY( 724 )                                              
      GO TO 143                                                         
  139 IS = -IDO                                                         
CX10725 CALL DOINX( 725 )                                               
CY10725 CALL DOINY( 725 )                                               
      DO 142 J=2,IP                                                     
         IS = IS+IDO                                                    
         DO 141 K=1,L1                                                  
            IDIJ = IS                                                   
            DO 140 I=3,IDO,2                                            
               IDIJ = IDIJ+2                                            
               C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J)  
               C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J)    
  140       CONTINUE                                                    
  141    CONTINUE                                                       
  142 CONTINUE                                                          
CX20726 CALL DOOUTX( 726 )                                              
CY20726 CALL DOOUTY( 726 )                                              
  143 CONTINUE                                                          
CX40148 CALL SBOUTX (148)                                               
CY40148 CALL SBOUTY (148)                                               
      RETURN                                                            
      END                                                               
      SUBROUTINE RFFTF (N,R,WSAVE)                                      
      DIMENSION       R(*)       ,WSAVE(*)                              
CX30149 CALL SBINX (149)                                                
CY30149 CALL SBINY (149)                                                
      IF (N .EQ. 1) THEN                                                
CX40150 CALL SBOUTX (150)                                               
CY40150 CALL SBOUTY (150)                                               
      RETURN                                                            
      ENDIF                                                             
      CALL RFFTF1 (N,R,WSAVE,WSAVE(N+1),WSAVE(2*N+1))                   
CX40150 CALL SBOUTX (150)                                               
CY40150 CALL SBOUTY (150)                                               
      RETURN                                                            
      END                                                               
      SUBROUTINE RFFTF1 (N,C,CH,WA,IFAC)                                
      DIMENSION       CH(*)      ,C(*)       ,WA(*)      ,IFAC(*)       
CX30151 CALL SBINX (151)                                                
CY30151 CALL SBINY (151)                                                
      NF = IFAC(2)                                                      
      NA = 1                                                            
      L2 = N                                                            
      IW = N                                                            
CX10727 CALL DOINX( 727 )                                               
CY10727 CALL DOINY( 727 )                                               
      DO 111 K1=1,NF                                                    
         KH = NF-K1                                                     
         IP = IFAC(KH+3)                                                
         L1 = L2/IP                                                     
         IDO = N/L2                                                     
         IDL1 = IDO*L1                                                  
         IW = IW-(IP-1)*IDO                                             
         NA = 1-NA                                                      
         IF (IP .NE. 4) GO TO 102                                       
         IX2 = IW+IDO                                                   
         IX3 = IX2+IDO                                                  
         IF (NA .NE. 0) GO TO 101                                       
         CALL RADF4 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3))                
         GO TO 110                                                      
  101    CALL RADF4 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3))                
         GO TO 110                                                      
  102    IF (IP .NE. 2) GO TO 104                                       
         IF (NA .NE. 0) GO TO 103                                       
         CALL RADF2 (IDO,L1,C,CH,WA(IW))                                
         GO TO 110                                                      
  103    CALL RADF2 (IDO,L1,CH,C,WA(IW))                                
         GO TO 110                                                      
  104    IF (IP .NE. 3) GO TO 106                                       
         IX2 = IW+IDO                                                   
         IF (NA .NE. 0) GO TO 105                                       
         CALL RADF3 (IDO,L1,C,CH,WA(IW),WA(IX2))                        
         GO TO 110                                                      
  105    CALL RADF3 (IDO,L1,CH,C,WA(IW),WA(IX2))                        
         GO TO 110                                                      
  106    IF (IP .NE. 5) GO TO 108                                       
         IX2 = IW+IDO                                                   
         IX3 = IX2+IDO                                                  
         IX4 = IX3+IDO                                                  
         IF (NA .NE. 0) GO TO 107                                       
         CALL RADF5 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4))        
         GO TO 110                                                      
  107    CALL RADF5 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4))        
         GO TO 110                                                      
  108    IF (IDO .EQ. 1) NA = 1-NA                                      
         IF (NA .NE. 0) GO TO 109                                       
         CALL RADFG (IDO,IP,L1,IDL1,C,C,C,CH,CH,WA(IW))                 
         NA = 1                                                         
         GO TO 110                                                      
  109    CALL RADFG (IDO,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW))                
         NA = 0                                                         
  110    L2 = L1                                                        
  111 CONTINUE                                                          
CX20728 CALL DOOUTX( 728 )                                              
CY20728 CALL DOOUTY( 728 )                                              
      IF (NA .EQ. 1) THEN                                               
CX40152 CALL SBOUTX (152)                                               
CY40152 CALL SBOUTY (152)                                               
      RETURN                                                            
      ENDIF                                                             
CX10729 CALL DOINX( 729 )                                               
CY10729 CALL DOINY( 729 )                                               
      DO 112 I=1,N                                                      
         C(I) = CH(I)                                                   
  112 CONTINUE                                                          
CX20730 CALL DOOUTX( 730 )                                              
CY20730 CALL DOOUTY( 730 )                                              
CX40152 CALL SBOUTX (152)                                               
CY40152 CALL SBOUTY (152)                                               
      RETURN                                                            
      END                                                               
      SUBROUTINE RADF2 (IDO,L1,CC,CH,WA1)                               
      DIMENSION       CH(IDO,2,L1)           ,CC(IDO,L1,2)           ,  
     1                WA1(*)                                            
CX30153 CALL SBINX (153)                                                
CY30153 CALL SBINY (153)                                                
CX10731 CALL DOINX( 731 )                                               
CY10731 CALL DOINY( 731 )                                               
      DO 101 K=1,L1                                                     
         CH(1,1,K) = CC(1,K,1)+CC(1,K,2)                                
         CH(IDO,2,K) = CC(1,K,1)-CC(1,K,2)                              
  101 CONTINUE                                                          
CX20732 CALL DOOUTX( 732 )                                              
CY20732 CALL DOOUTY( 732 )                                              
      IF (IDO-2) 107,105,102                                            
  102 IDP2 = IDO+2                                                      
CX10733 CALL DOINX( 733 )                                               
CY10733 CALL DOINY( 733 )                                               
      DO 104 K=1,L1                                                     
         DO 103 I=3,IDO,2                                               
            IC = IDP2-I                                                 
            TR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2)               
            TI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2)               
            CH(I,1,K) = CC(I,K,1)+TI2                                   
            CH(IC,2,K) = TI2-CC(I,K,1)                                  
            CH(I-1,1,K) = CC(I-1,K,1)+TR2                               
            CH(IC-1,2,K) = CC(I-1,K,1)-TR2                              
  103    CONTINUE                                                       
  104 CONTINUE                                                          
CX20734 CALL DOOUTX( 734 )                                              
CY20734 CALL DOOUTY( 734 )                                              
      IF (MOD(IDO,2) .EQ. 1) THEN                                       
CX40154 CALL SBOUTX (154)                                               
CY40154 CALL SBOUTY (154)                                               
      RETURN                                                            
      ENDIF                                                             
  105 CONTINUE                                                          
CX10735 CALL DOINX( 735 )                                               
CY10735 CALL DOINY( 735 )                                               
      DO      106      K=1,L1                                           
         CH(1,2,K) = -CC(IDO,K,2)                                       
         CH(IDO,1,K) = CC(IDO,K,1)                                      
  106 CONTINUE                                                          
CX20736 CALL DOOUTX( 736 )                                              
CY20736 CALL DOOUTY( 736 )                                              
  107 CONTINUE                                                          
CX40154 CALL SBOUTX (154)                                               
CY40154 CALL SBOUTY (154)                                               
      RETURN                                                            
      END                                                               
      SUBROUTINE RADF3 (IDO,L1,CC,CH,WA1,WA2)                           
      DIMENSION       CH(IDO,3,L1)           ,CC(IDO,L1,3)           ,  
     1                WA1(*)     ,WA2(*)                                
      PARAMETER (TAUR = -.5, TAUI = .866025403784439)                   
CX30155 CALL SBINX (155)                                                
CY30155 CALL SBINY (155)                                                
CX10737 CALL DOINX( 737 )                                               
CY10737 CALL DOINY( 737 )                                               
      DO 101 K=1,L1                                                     
         CR2 = CC(1,K,2)+CC(1,K,3)                                      
         CH(1,1,K) = CC(1,K,1)+CR2                                      
         CH(1,3,K) = TAUI*(CC(1,K,3)-CC(1,K,2))                         
         CH(IDO,2,K) = CC(1,K,1)+TAUR*CR2                               
  101 CONTINUE                                                          
CX20738 CALL DOOUTX( 738 )                                              
CY20738 CALL DOOUTY( 738 )                                              
      IF (IDO .EQ. 1) THEN                                              
CX40156 CALL SBOUTX (156)                                               
CY40156 CALL SBOUTY (156)                                               
      RETURN                                                            
      ENDIF                                                             
      IDP2 = IDO+2                                                      
CX10739 CALL DOINX( 739 )                                               
CY10739 CALL DOINY( 739 )                                               
      DO 103 K=1,L1                                                     
         DO 102 I=3,IDO,2                                               
            IC = IDP2-I                                                 
            DR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2)               
            DI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2)               
            DR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3)               
            DI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3)               
            CR2 = DR2+DR3                                               
            CI2 = DI2+DI3                                               
            CH(I-1,1,K) = CC(I-1,K,1)+CR2                               
            CH(I,1,K) = CC(I,K,1)+CI2                                   
            TR2 = CC(I-1,K,1)+TAUR*CR2                                  
            TI2 = CC(I,K,1)+TAUR*CI2                                    
            TR3 = TAUI*(DI2-DI3)                                        
            TI3 = TAUI*(DR3-DR2)                                        
            CH(I-1,3,K) = TR2+TR3                                       
            CH(IC-1,2,K) = TR2-TR3                                      
            CH(I,3,K) = TI2+TI3                                         
            CH(IC,2,K) = TI3-TI2                                        
  102    CONTINUE                                                       
  103 CONTINUE                                                          
CX20740 CALL DOOUTX( 740 )                                              
CY20740 CALL DOOUTY( 740 )                                              
CX40156 CALL SBOUTX (156)                                               
CY40156 CALL SBOUTY (156)                                               
      RETURN                                                            
      END                                                               
      SUBROUTINE RADF4 (IDO,L1,CC,CH,WA1,WA2,WA3)                       
      DIMENSION       CC(IDO,L1,4)           ,CH(IDO,4,L1)           ,  
     1                WA1(*)     ,WA2(*)     ,WA3(*)                    
      PARAMETER (HSQT2 = .7071067811865475)                             
CX30157 CALL SBINX (157)                                                
CY30157 CALL SBINY (157)                                                
CX10741 CALL DOINX( 741 )                                               
CY10741 CALL DOINY( 741 )                                               
      DO 101 K=1,L1                                                     
         TR1 = CC(1,K,2)+CC(1,K,4)                                      
         TR2 = CC(1,K,1)+CC(1,K,3)                                      
         CH(1,1,K) = TR1+TR2                                            
         CH(IDO,4,K) = TR2-TR1                                          
         CH(IDO,2,K) = CC(1,K,1)-CC(1,K,3)                              
         CH(1,3,K) = CC(1,K,4)-CC(1,K,2)                                
  101 CONTINUE                                                          
CX20742 CALL DOOUTX( 742 )                                              
CY20742 CALL DOOUTY( 742 )                                              
      IF (IDO-2) 107,105,102                                            
  102 IDP2 = IDO+2                                                      
CX10743 CALL DOINX( 743 )                                               
CY10743 CALL DOINY( 743 )                                               
      DO 104 K=1,L1                                                     
         DO 103 I=3,IDO,2                                               
            IC = IDP2-I                                                 
            CR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2)               
            CI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2)               
            CR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3)               
            CI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3)               
            CR4 = WA3(I-2)*CC(I-1,K,4)+WA3(I-1)*CC(I,K,4)               
            CI4 = WA3(I-2)*CC(I,K,4)-WA3(I-1)*CC(I-1,K,4)               
            TR1 = CR2+CR4                                               
            TR4 = CR4-CR2                                               
            TI1 = CI2+CI4                                               
            TI4 = CI2-CI4                                               
            TI2 = CC(I,K,1)+CI3                                         
            TI3 = CC(I,K,1)-CI3                                         
            TR2 = CC(I-1,K,1)+CR3                                       
            TR3 = CC(I-1,K,1)-CR3                                       
            CH(I-1,1,K) = TR1+TR2                                       
            CH(IC-1,4,K) = TR2-TR1                                      
            CH(I,1,K) = TI1+TI2                                         
            CH(IC,4,K) = TI1-TI2                                        
            CH(I-1,3,K) = TI4+TR3                                       
            CH(IC-1,2,K) = TR3-TI4                                      
            CH(I,3,K) = TR4+TI3                                         
            CH(IC,2,K) = TR4-TI3                                        
  103    CONTINUE                                                       
  104 CONTINUE                                                          
CX20744 CALL DOOUTX( 744 )                                              
CY20744 CALL DOOUTY( 744 )                                              
      IF (MOD(IDO,2) .EQ. 1) THEN                                       
CX40158 CALL SBOUTX (158)                                               
CY40158 CALL SBOUTY (158)                                               
      RETURN                                                            
      ENDIF                                                             
  105 CONTINUE                                                          
CX10745 CALL DOINX( 745 )                                               
CY10745 CALL DOINY( 745 )                                               
      DO 106 K=1,L1                                                     
         TI1 = -HSQT2*(CC(IDO,K,2)+CC(IDO,K,4))                         
         TR1 = HSQT2*(CC(IDO,K,2)-CC(IDO,K,4))                          
         CH(IDO,1,K) = TR1+CC(IDO,K,1)                                  
         CH(IDO,3,K) = CC(IDO,K,1)-TR1                                  
         CH(1,2,K) = TI1-CC(IDO,K,3)                                    
         CH(1,4,K) = TI1+CC(IDO,K,3)                                    
  106 CONTINUE                                                          
CX20746 CALL DOOUTX( 746 )                                              
CY20746 CALL DOOUTY( 746 )                                              
  107 CONTINUE                                                          
CX40158 CALL SBOUTX (158)                                               
CY40158 CALL SBOUTY (158)                                               
      RETURN                                                            
      END                                                               
      SUBROUTINE RADF5 (IDO,L1,CC,CH,WA1,WA2,WA3,WA4)                   
      DIMENSION       CC(IDO,L1,5)           ,CH(IDO,5,L1)           ,  
     1                WA1(*)     ,WA2(*)     ,WA3(*)     ,WA4(*)        
      PARAMETER (TR11 = .309016994374947, TI11 = .951056516295154,      
     *           TR12 = -.809016994374947, TI12 = .587785252292473)     
CX30159 CALL SBINX (159)                                                
CY30159 CALL SBINY (159)                                                
CX10747 CALL DOINX( 747 )                                               
CY10747 CALL DOINY( 747 )                                               
      DO 101 K=1,L1                                                     
         CR2 = CC(1,K,5)+CC(1,K,2)                                      
         CI5 = CC(1,K,5)-CC(1,K,2)                                      
         CR3 = CC(1,K,4)+CC(1,K,3)                                      
         CI4 = CC(1,K,4)-CC(1,K,3)                                      
         CH(1,1,K) = CC(1,K,1)+CR2+CR3                                  
         CH(IDO,2,K) = CC(1,K,1)+TR11*CR2+TR12*CR3                      
         CH(1,3,K) = TI11*CI5+TI12*CI4                                  
         CH(IDO,4,K) = CC(1,K,1)+TR12*CR2+TR11*CR3                      
         CH(1,5,K) = TI12*CI5-TI11*CI4                                  
  101 CONTINUE                                                          
CX20748 CALL DOOUTX( 748 )                                              
CY20748 CALL DOOUTY( 748 )                                              
      IF (IDO .EQ. 1) THEN                                              
CX40160 CALL SBOUTX (160)                                               
CY40160 CALL SBOUTY (160)                                               
      RETURN                                                            
      ENDIF                                                             
      IDP2 = IDO+2                                                      
CX10749 CALL DOINX( 749 )                                               
CY10749 CALL DOINY( 749 )                                               
      DO 103 K=1,L1                                                     
         DO 102 I=3,IDO,2                                               
            IC = IDP2-I                                                 
            DR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2)               
            DI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2)               
            DR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3)               
            DI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3)               
            DR4 = WA3(I-2)*CC(I-1,K,4)+WA3(I-1)*CC(I,K,4)               
            DI4 = WA3(I-2)*CC(I,K,4)-WA3(I-1)*CC(I-1,K,4)               
            DR5 = WA4(I-2)*CC(I-1,K,5)+WA4(I-1)*CC(I,K,5)               
            DI5 = WA4(I-2)*CC(I,K,5)-WA4(I-1)*CC(I-1,K,5)               
            CR2 = DR2+DR5                                               
            CI5 = DR5-DR2                                               
            CR5 = DI2-DI5                                               
            CI2 = DI2+DI5                                               
            CR3 = DR3+DR4                                               
            CI4 = DR4-DR3                                               
            CR4 = DI3-DI4                                               
            CI3 = DI3+DI4                                               
            CH(I-1,1,K) = CC(I-1,K,1)+CR2+CR3                           
            CH(I,1,K) = CC(I,K,1)+CI2+CI3                               
            TR2 = CC(I-1,K,1)+TR11*CR2+TR12*CR3                         
            TI2 = CC(I,K,1)+TR11*CI2+TR12*CI3                           
            TR3 = CC(I-1,K,1)+TR12*CR2+TR11*CR3                         
            TI3 = CC(I,K,1)+TR12*CI2+TR11*CI3                           
            TR5 = TI11*CR5+TI12*CR4                                     
            TI5 = TI11*CI5+TI12*CI4                                     
            TR4 = TI12*CR5-TI11*CR4                                     
            TI4 = TI12*CI5-TI11*CI4                                     
            CH(I-1,3,K) = TR2+TR5                                       
            CH(IC-1,2,K) = TR2-TR5                                      
            CH(I,3,K) = TI2+TI5                                         
            CH(IC,2,K) = TI5-TI2                                        
            CH(I-1,5,K) = TR3+TR4                                       
            CH(IC-1,4,K) = TR3-TR4                                      
            CH(I,5,K) = TI3+TI4                                         
            CH(IC,4,K) = TI4-TI3                                        
  102    CONTINUE                                                       
  103 CONTINUE                                                          
CX20750 CALL DOOUTX( 750 )                                              
CY20750 CALL DOOUTY( 750 )                                              
CX40160 CALL SBOUTX (160)                                               
CY40160 CALL SBOUTY (160)                                               
      RETURN                                                            
      END                                                               
      SUBROUTINE RADFG (IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA)              
      DIMENSION       CH(IDO,L1,IP)          ,CC(IDO,IP,L1)          ,  
     1                C1(IDO,L1,IP)          ,C2(IDL1,IP),              
     2                CH2(IDL1,IP)           ,WA(1)                     
      PARAMETER (TPI = 6.28318530717959)                                
CX30161 CALL SBINX (161)                                                
CY30161 CALL SBINY (161)                                                
      ARG = TPI/FLOAT(IP)                                               
      DCP = COS(ARG)                                                    
      DSP = SIN(ARG)                                                    
      IPPH = (IP+1)/2                                                   
      IPP2 = IP+2                                                       
      IDP2 = IDO+2                                                      
      NBD = (IDO-1)/2                                                   
      IF (IDO .EQ. 1) GO TO 119                                         
CX10751 CALL DOINX( 751 )                                               
CY10751 CALL DOINY( 751 )                                               
      DO 101 IK=1,IDL1                                                  
         CH2(IK,1) = C2(IK,1)                                           
  101 CONTINUE                                                          
CX20752 CALL DOOUTX( 752 )                                              
CY20752 CALL DOOUTY( 752 )                                              
CX10753 CALL DOINX( 753 )                                               
CY10753 CALL DOINY( 753 )                                               
      DO 103 J=2,IP                                                     
         DO 102 K=1,L1                                                  
            CH(1,K,J) = C1(1,K,J)                                       
  102    CONTINUE                                                       
  103 CONTINUE                                                          
CX20754 CALL DOOUTX( 754 )                                              
CY20754 CALL DOOUTY( 754 )                                              
      IF (NBD .GT. L1) GO TO 107                                        
      IS = -IDO                                                         
CX10755 CALL DOINX( 755 )                                               
CY10755 CALL DOINY( 755 )                                               
      DO 106 J=2,IP                                                     
         IS = IS+IDO                                                    
         IDIJ = IS                                                      
         DO 105 I=3,IDO,2                                               
            IDIJ = IDIJ+2                                               
            DO 104 K=1,L1                                               
               CH(I-1,K,J) = WA(IDIJ-1)*C1(I-1,K,J)+WA(IDIJ)*C1(I,K,J)  
               CH(I,K,J) = WA(IDIJ-1)*C1(I,K,J)-WA(IDIJ)*C1(I-1,K,J)    
  104       CONTINUE                                                    
  105    CONTINUE                                                       
  106 CONTINUE                                                          
CX20756 CALL DOOUTX( 756 )                                              
CY20756 CALL DOOUTY( 756 )                                              
      GO TO 111                                                         
  107 IS = -IDO                                                         
CX10757 CALL DOINX( 757 )                                               
CY10757 CALL DOINY( 757 )                                               
      DO 110 J=2,IP                                                     
         IS = IS+IDO                                                    
         DO 109 K=1,L1                                                  
            IDIJ = IS                                                   
            DO 108 I=3,IDO,2                                            
               IDIJ = IDIJ+2                                            
               CH(I-1,K,J) = WA(IDIJ-1)*C1(I-1,K,J)+WA(IDIJ)*C1(I,K,J)  
               CH(I,K,J) = WA(IDIJ-1)*C1(I,K,J)-WA(IDIJ)*C1(I-1,K,J)    
  108       CONTINUE                                                    
  109    CONTINUE                                                       
  110 CONTINUE                                                          
CX20758 CALL DOOUTX( 758 )                                              
CY20758 CALL DOOUTY( 758 )                                              
  111 IF (NBD .LT. L1) GO TO 115                                        
CX10759 CALL DOINX( 759 )                                               
CY10759 CALL DOINY( 759 )                                               
      DO 114 J=2,IPPH                                                   
         JC = IPP2-J                                                    
         DO 113 K=1,L1                                                  
            DO 112 I=3,IDO,2                                            
               C1(I-1,K,J) = CH(I-1,K,J)+CH(I-1,K,JC)                   
               C1(I-1,K,JC) = CH(I,K,J)-CH(I,K,JC)                      
               C1(I,K,J) = CH(I,K,J)+CH(I,K,JC)                         
               C1(I,K,JC) = CH(I-1,K,JC)-CH(I-1,K,J)                    
  112       CONTINUE                                                    
  113    CONTINUE                                                       
  114 CONTINUE                                                          
CX20760 CALL DOOUTX( 760 )                                              
CY20760 CALL DOOUTY( 760 )                                              
      GO TO 121                                                         
  115 CONTINUE                                                          
CX10761 CALL DOINX( 761 )                                               
CY10761 CALL DOINY( 761 )                                               
      DO      118      J=2,IPPH                                         
         JC = IPP2-J                                                    
         DO 117 I=3,IDO,2                                               
            DO 116 K=1,L1                                               
               C1(I-1,K,J) = CH(I-1,K,J)+CH(I-1,K,JC)                   
               C1(I-1,K,JC) = CH(I,K,J)-CH(I,K,JC)                      
               C1(I,K,J) = CH(I,K,J)+CH(I,K,JC)                         
               C1(I,K,JC) = CH(I-1,K,JC)-CH(I-1,K,J)                    
  116       CONTINUE                                                    
  117    CONTINUE                                                       
  118 CONTINUE                                                          
CX20762 CALL DOOUTX( 762 )                                              
CY20762 CALL DOOUTY( 762 )                                              
      GO TO 121                                                         
  119 CONTINUE                                                          
CX10763 CALL DOINX( 763 )                                               
CY10763 CALL DOINY( 763 )                                               
      DO      120      IK=1,IDL1                                        
         C2(IK,1) = CH2(IK,1)                                           
  120 CONTINUE                                                          
CX20764 CALL DOOUTX( 764 )                                              
CY20764 CALL DOOUTY( 764 )                                              
  121 CONTINUE                                                          
CX10765 CALL DOINX( 765 )                                               
CY10765 CALL DOINY( 765 )                                               
      DO      123      J=2,IPPH                                         
         JC = IPP2-J                                                    
         DO 122 K=1,L1                                                  
            C1(1,K,J) = CH(1,K,J)+CH(1,K,JC)                            
            C1(1,K,JC) = CH(1,K,JC)-CH(1,K,J)                           
  122    CONTINUE                                                       
  123 CONTINUE                                                          
CX20766 CALL DOOUTX( 766 )                                              
CY20766 CALL DOOUTY( 766 )                                              
C                                                                       
      AR1 = 1.                                                          
      AI1 = 0.                                                          
CX10767 CALL DOINX( 767 )                                               
CY10767 CALL DOINY( 767 )                                               
      DO 127 L=2,IPPH                                                   
         LC = IPP2-L                                                    
         AR1H = DCP*AR1-DSP*AI1                                         
         AI1 = DCP*AI1+DSP*AR1                                          
         AR1 = AR1H                                                     
         DO 124 IK=1,IDL1                                               
            CH2(IK,L) = C2(IK,1)+AR1*C2(IK,2)                           
            CH2(IK,LC) = AI1*C2(IK,IP)                                  
  124    CONTINUE                                                       
         DC2 = AR1                                                      
         DS2 = AI1                                                      
         AR2 = AR1                                                      
         AI2 = AI1                                                      
         DO 126 J=3,IPPH                                                
            JC = IPP2-J                                                 
            AR2H = DC2*AR2-DS2*AI2                                      
            AI2 = DC2*AI2+DS2*AR2                                       
            AR2 = AR2H                                                  
            DO 125 IK=1,IDL1                                            
               CH2(IK,L) = CH2(IK,L)+AR2*C2(IK,J)                       
               CH2(IK,LC) = CH2(IK,LC)+AI2*C2(IK,JC)                    
  125       CONTINUE                                                    
  126    CONTINUE                                                       
  127 CONTINUE                                                          
CX20768 CALL DOOUTX( 768 )                                              
CY20768 CALL DOOUTY( 768 )                                              
CX10769 CALL DOINX( 769 )                                               
CY10769 CALL DOINY( 769 )                                               
      DO 129 J=2,IPPH                                                   
         DO 128 IK=1,IDL1                                               
            CH2(IK,1) = CH2(IK,1)+C2(IK,J)                              
  128    CONTINUE                                                       
  129 CONTINUE                                                          
CX20770 CALL DOOUTX( 770 )                                              
CY20770 CALL DOOUTY( 770 )                                              
C                                                                       
      IF (IDO .LT. L1) GO TO 132                                        
CX10771 CALL DOINX( 771 )                                               
CY10771 CALL DOINY( 771 )                                               
      DO 131 K=1,L1                                                     
         DO 130 I=1,IDO                                                 
            CC(I,1,K) = CH(I,K,1)                                       
  130    CONTINUE                                                       
  131 CONTINUE                                                          
CX20772 CALL DOOUTX( 772 )                                              
CY20772 CALL DOOUTY( 772 )                                              
      GO TO 135                                                         
  132 CONTINUE                                                          
CX10773 CALL DOINX( 773 )                                               
CY10773 CALL DOINY( 773 )                                               
      DO      134      I=1,IDO                                          
         DO 133 K=1,L1                                                  
            CC(I,1,K) = CH(I,K,1)                                       
  133    CONTINUE                                                       
  134 CONTINUE                                                          
CX20774 CALL DOOUTX( 774 )                                              
CY20774 CALL DOOUTY( 774 )                                              
  135 CONTINUE                                                          
CX10775 CALL DOINX( 775 )                                               
CY10775 CALL DOINY( 775 )                                               
      DO      137      J=2,IPPH                                         
         JC = IPP2-J                                                    
         J2 = J+J                                                       
         DO 136 K=1,L1                                                  
            CC(IDO,J2-2,K) = CH(1,K,J)                                  
            CC(1,J2-1,K) = CH(1,K,JC)                                   
  136    CONTINUE                                                       
  137 CONTINUE                                                          
CX20776 CALL DOOUTX( 776 )                                              
CY20776 CALL DOOUTY( 776 )                                              
      IF (IDO .EQ. 1) THEN                                              
CX40162 CALL SBOUTX (162)                                               
CY40162 CALL SBOUTY (162)                                               
      RETURN                                                            
      ENDIF                                                             
      IF (NBD .LT. L1) GO TO 141                                        
CX10777 CALL DOINX( 777 )                                               
CY10777 CALL DOINY( 777 )                                               
      DO 140 J=2,IPPH                                                   
         JC = IPP2-J                                                    
         J2 = J+J                                                       
         DO 139 K=1,L1                                                  
            DO 138 I=3,IDO,2                                            
               IC = IDP2-I                                              
               CC(I-1,J2-1,K) = CH(I-1,K,J)+CH(I-1,K,JC)                
               CC(IC-1,J2-2,K) = CH(I-1,K,J)-CH(I-1,K,JC)               
               CC(I,J2-1,K) = CH(I,K,J)+CH(I,K,JC)                      
               CC(IC,J2-2,K) = CH(I,K,JC)-CH(I,K,J)                     
  138       CONTINUE                                                    
  139    CONTINUE                                                       
  140 CONTINUE                                                          
CX20778 CALL DOOUTX( 778 )                                              
CY20778 CALL DOOUTY( 778 )                                              
CX40162 CALL SBOUTX (162)                                               
CY40162 CALL SBOUTY (162)                                               
      RETURN                                                            
  141 CONTINUE                                                          
CX10779 CALL DOINX( 779 )                                               
CY10779 CALL DOINY( 779 )                                               
      DO      144      J=2,IPPH                                         
         JC = IPP2-J                                                    
         J2 = J+J                                                       
         DO 143 I=3,IDO,2                                               
            IC = IDP2-I                                                 
            DO 142 K=1,L1                                               
               CC(I-1,J2-1,K) = CH(I-1,K,J)+CH(I-1,K,JC)                
               CC(IC-1,J2-2,K) = CH(I-1,K,J)-CH(I-1,K,JC)               
               CC(I,J2-1,K) = CH(I,K,J)+CH(I,K,JC)                      
               CC(IC,J2-2,K) = CH(I,K,JC)-CH(I,K,J)                     
  142       CONTINUE                                                    
  143    CONTINUE                                                       
  144 CONTINUE                                                          
CX20780 CALL DOOUTX( 780 )                                              
CY20780 CALL DOOUTY( 780 )                                              
CX40162 CALL SBOUTX (162)                                               
CY40162 CALL SBOUTY (162)                                               
      RETURN                                                            
      END                                                               
C                                                                       
C **********************************************************************
C *   B O U N D A R Y    L A Y E R    S O L V E R   F O R     KM  KH   *
C *====================================================================*
C *  BOUNDARY LAYER SOLVER FOR THE MESO+SYNOPTIC WIND AND TEMPERATURE. *
C *  U,T ARE UTILITY VECTORS FOR DATA MANIPULATIONS. (HELP,HELPA)      *
C *  POTT,UX,VY ARE THE PERTURBATION TEMPERATURE AND WINDS, ZET IS     *
C *  THE GEOMETRIC HEIGHT, DKZM AND SKZH ARE THE  EDDY DIFFUSIVITIES   *
C *  DZMIN IS THE MINIMUM DIFFUSIVITY SPECIFIED IN THE DATA, Z0 IS THE *
C *  TERRAIN ROUGHNESS, ELEV IS THE TOPOGRAPHY, NX,NY,NZ ARE THE       *
C *  DOMAIN GRID POINTS, HMIX IS THE MIXING HEIGHT OR  THE HEIGHT      *
C *  OF THE BOUNDARY LAYER, STEPH IS THE BOUNDARY LAYER HEIGHT AT THE  *
C *  PREVIOUS TIME STEP, OBUK IS THE MONIN OBUKOV LENGTH, USTR IS      *
C *  FRICTIONAL VELOCITY, VDEP IS THE DRY DEPOSITIONAL VELOCITY, WZ IS *
C *  THE VERTICAL VELOCITY, UM, VM AND TM ARE THE SYNOPTIC WIND AND    *
C *  TEMPERATURE COMPONENTS RESPECTIVELY, TSTR IS THE TURBULENT        *
C *  POTENTIAL TEMPERATURE, FXC+FYC THE SPECTRAL DIFFUSSIVITIES IN X,Y *
C *  AND TAVR IS THE AVERAGE TEMPERATURE IN THE SURFACE LAYER          *
C **********************************************************************
C                                                                       
      SUBROUTINE DKZMH(U,T,TM,UM,VM,POTT,UX,VY,WZ,ZET,DKZM,DKZH,DZMIN,  
     *Z0,ELEV,NX,NX1,NY,NY1,NZ,HMIX,STEPH,TAVR,OBUK,USTR,TSTR,VDEP,NSMT,
     *F,NFILT,ISTEP,DELTAT,SAVEX,SAVEY,FX,FY,FXC,FYC,DCDX,DCDY,TSL,DLF) 
C                                                                       
      REAL UX(NX,NY,NZ),VY(NX,NY,NZ),POTT(NX,NY,NZ),DKZM(NX,NY,NZ)      
      REAL DKZH(NX,NY,NZ),WZ(NX,NY,NZ),OBUK(NX,NY),USTR(NX,NY)          
      REAL VDEP(NX,NY),TAVR(NX,NY),TSTR(NX,NY),STEPH(NX,NY),Z0(NX,NY)   
      REAL ELEV(NX,NY),HMIX(NX,NY),U(1),T(1),TM(1),VM(1),UM(1),ZET(1)   
      REAL SAVEX(1),SAVEY(1),FX(1),FY(1),FXC(1),FYC(1),DCDX(1),DCDY(1)  
CX30163 CALL SBINX (163)                                                
CY30163 CALL SBINY (163)                                                
CX10781 CALL DOINX( 781 )                                               
CY10781 CALL DOINY( 781 )                                               
C                                                                       
      DO 30 J=1,NY                                                      
         DO 20 I=1,NX                                                   
C                                                                       
C           CALCULATE ROUGHNES LENGTH BY USING THE FRICTIONAL           
C           VELOCITY USTAR ONLY FOR LAKE (ELEV<0.) (PIERSON 1978)       
C                                                                       
            ZMH=HMIX(I,J)                                               
            ZNOT=Z0(I,J)                                                
            IF(ELEV(I,J).LT.0) THEN                                     
               USTAR=MAX(USTR(I,J),0.001)                               
               ZNOT=3.905E-5/USTAR+1.6046E-3*USTAR**2-1.747E-4          
               Z0(I,J)=ZNOT                                             
            ENDIF                                                       
C                                                                       
C           FILL VECTORS WITH PERTURBATION WIND AND TEMPERATURE         
C                                                                       
C *****   REMEMBER  K(MESO)=K(MESO+SYNOP)-K(SYNOP)  ********************
C                                                                       
            DO 10 K=1,NZ                                                
               IF(I.EQ.1.OR.I.EQ.NX) THEN                               
                  TX=0.5*POTT(I,J,K)                                    
                  WUX=0.5*UX(I,J,K)                                     
                  WVX=0.5*VY(I,J,K)                                     
                                     ELSE                               
                  TX=0.25*(POTT(I-1,J,K)+POTT(I+1,J,K))                 
                  WUX=0.25*(UX(I-1,J,K)+UX(I+1,J,K))                    
                  WVX=0.25*(VY(I-1,J,K)+VY(I+1,J,K))                    
               ENDIF                                                    
               IF(J.EQ.1.OR.J.EQ.NY) THEN                               
                  TY=0.5*POTT(I,J,K)                                    
                  WUY=0.5*UX(I,J,K)                                     
                  WVY=0.5*VY(I,J,K)                                     
                                     ELSE                               
                  TY=0.25*(POTT(I,J-1,K)+POTT(I,J+1,K))                 
                  WUY=0.25*(UX(I,J-1,K)+UX(I,J+1,K))                    
                  WVY=0.25*(VY(I,J-1,K)+VY(I,J+1,K))                    
               ENDIF                                                    
C                                                                       
C              ADD THE SYNOPTIC VARIABLES TO THE MESOSCALE, AND         
C              CALCULATE THE TOTAL WIND EFFECT (U+V)**1/2               
C                                                                       
               XW=(UX(I,J,K)+WUX+WUY)/2.+UM(K)                          
               YW=(VY(I,J,K)+WVX+WVY)/2.+VM(K)                          
               U(K)=SQRT(XW*XW+YW*YW)                                   
               T(K)=(POTT(I,J,K)+TX+TY)/2.+TM(K)                        
 10         CONTINUE                                                    
C                                                                       
C       CALCULATE SURFACE LAYER PARAMETERS                              
C                                                                       
            CALL SFCPAR(U,T,ZET,NZ,ZNOT,USTAR,TSTAR,DL,ZMH,TSL,TMES)    
C                                                                       
C           DUMP ALL HORIZONTAL BOUNDARY LAYER PARAMETERS BACK          
C                                                                       
            OBUK(I,J)=DL                                                
            USTR(I,J)=USTAR                                             
            TSTR(I,J)=TSTAR                                             
            TAVR(I,J)=TMES                                              
 20      CONTINUE                                                       
 30   CONTINUE                                                          
CX20782 CALL DOOUTX( 782 )                                              
CY20782 CALL DOOUTY( 782 )                                              
C                                                                       
C      SMOOTH THE BOUNDARY LAYER PARAMETERS TO GET RID OF THE           
C      TWO-GRID NOISE IN THE SURFACE LAYER.                             
C                                                                       
      CALL HORSMT(NX,NY,USTR)                                           
      CALL HORSMT(NX,NY,TSTR)                                           
C                                                                       
C     CALCULATE A NEW MONIN OBUKHOV LENGTH FROM THE SURFACE LAYER       
C     RELATION TO HAVE A BALANCE BETWEEN U*,T* AND L                    
C     FIND THE TOP OF THE BOUNDARY LAYER BY USING DEARDORFFS AND        
C     SMEDAS PROGNOSTIC RELATION VIA PSEUDOSPECTRAL METHODS.            
C                                                                       
      CALL TOPBL(NX,NX1,NY,NY1,NZ,USTR,TSTR,OBUK,TAVR,                  
     *HMIX,STEPH,UX,UM,VY,VM,WZ,POTT,TM,ZET,U,T,NFILT,                  
     *ISTEP,F,DELTAT,SAVEX,SAVEY,FX,FY,FXC,FYC,DCDX,DCDY)               
CX10783 CALL DOINX( 783 )                                               
CY10783 CALL DOINY( 783 )                                               
C                                                                       
C     IMPOSE RESTRICTIONS ON THE BOUNDARY LAYER HEIGHT, AND CALCULATE   
C     THE DRY DEPOSITIONAL VELOCITIES ACCORDING TO WALCHEK              
C                                                                       
      DO 60 J=1,NY                                                      
         DO 50 I=1,NX                                                   
            DL=OBUK(I,J)                                                
            TMES=TAVR(I,J)                                              
            USTAR=USTR(I,J)                                             
            ZMH=MAX(40.,HMIX(I,J))                                      
            ZMH=MIN(ZMH,2000.)                                          
            HMIX(I,J)=ZMH                                               
            ZNOT=Z0(I,J)                                                
            DEPFAC=USTAR/500.                                           
C                                                                       
C           STORE DRY DEPOSITION VELOCITIES IN STABLE AND               
C           UNSTABLE CONDITIONS.                                        
C                                                                       
            IF(DL.GE.0) THEN                                            
               VDEP(I,J)=DEPFAC                                         
                        ELSE                                            
               ZC=ZMH/DL                                                
               IF(ZC.LT.-30.) THEN                                      
                  VDEP(I,J)=0.5*DEPFAC*((-ZC)**0.6666667)               
                              ELSE                                      
                  VDEP(I,J)=DEPFAC*(1.+(-300/DL)**0.6666667)            
               ENDIF                                                    
            ENDIF                                                       
            VDEP(I,J)=MIN(0.004,VDEP(I,J))                              
C                                                                       
C       CALCULATE THE EDDY DIFFUSIVITY COEFFICIENTS FOR HEAT AND        
C       MOMENTUM IN THE BOUNDARY LAYER FOR EVERY VERTICAL COLUMN        
C                                                                       
            CALL BLSOLV(ZET,NZ,ZNOT,USTAR,DL,DZMIN,U,T,ZMH,TSL)         
C                                                                       
C      DUMP THE EDDY DIFFUSIVITIES ON A 3-D GRID AND SMOOTH             
C      HORIZONTALLY FOR AVOIDING HIGH LOCAL FORCING IN ADVECTION TERMS  
C                                                                       
            DO 40 K=1,NZ                                                
               DKZM(I,J,K)=U(K)                                         
               DKZH(I,J,K)=T(K)                                         
 40         CONTINUE                                                    
 50      CONTINUE                                                       
 60   CONTINUE                                                          
CX20784 CALL DOOUTX( 784 )                                              
CY20784 CALL DOOUTY( 784 )                                              
C                                                                       
      CALL HORSMT(NX,NY,VDEP)                                           
      CALL SMOOTH(DKZM,NX,NY,NZ)                                        
      CALL SMOOTH(DKZH,NX,NY,NZ)                                        
CX40164 CALL SBOUTX (164)                                               
CY40164 CALL SBOUTY (164)                                               
                                                                        
      RETURN                                                            
      END                                                               
C                                                                       
C **********************************************************************
C *  ROUTINE TO CALCULATE THE TIME DEPENDENT MIXING HEIGHT H WHICH IS  *
C *            THE TOP OF THE PLANETARY BOUNDARY LAYER                 *
C **********************************************************************
C                                                                       
      SUBROUTINE TOPBL(NX,NX1,NY,NY1,NZ,USTR,TSTR,OBUK,TAVR,            
     *HMIX,STEPH,UX,UM,VY,VM,WZ,POTT,TM,ZET,HELP,HELPA,NFILT,           
     *ISTEP,F,DELTAT,SAVEX,SAVEY,FX,FY,FXC,FYC,DCDX,DCDY)               
C                                                                       
      REAL UX(NX,NY,NZ),VY(NX,NY,NZ),POTT(NX,NY,NZ),WZ(NX,NY,NZ)        
      REAL DCDX(1),DCDY(1),HMIX(NX,NY),STEPH(NX,NY),TAVR(NX,NY)         
      REAL USTR(NX,NY),TSTR(NX,NY),OBUK(NX,NY),UM(1),VM(1),TM(1),ZET(1) 
      REAL HELP(1),HELPA(1),SAVEX(1),SAVEY(1),FX(1),FY(1),FXC(1),FYC(1) 
CX30165 CALL SBINX (165)                                                
CY30165 CALL SBINY (165)                                                
C                                                                       
C     CALCULATE THE DERIVATIVES DH/DX,DH/DY  VIA FFT                    
C                                                                       
      CALL DCTDX(NX,NY,NX1,NFILT,HMIX,DCDX,HELP,HELPA,FX,FXC,SAVEX)     
      IF(NY.GT.1)                                                       
     *CALL DCTDX(NX,NY,NY1,NFILT,HMIX,DCDY,HELP,HELPA,FY,FYC,SAVEY)     
C                                                                       
C     RUN THE TIME LOOP                                                 
C                                                                       
      LOOP=NX*NY                                                        
C                                                                       
C     FIND  ADVECTION, CONVECTION AND HEATING RATES                     
C     K=0.35, G=9.81 THEIR PRODUCT IS 3.4335                            
C                                                                       
      L=0                                                               
CX10785 CALL DOINX( 785 )                                               
CY10785 CALL DOINY( 785 )                                               
      DO 40 J=1,NY                                                      
         DO 30 I=1,NX                                                   
            ZMH=HMIX(I,J)                                               
            USTAR=USTR(I,J)                                             
            TSTAR=TSTR(I,J)                                             
            TSTAB=ABS(TSTAR)                                            
C                                                                       
C       CORRECT THE MONIN-OBUKHOV LENGTH                                
C                                                                       
CGAO            OB=OBUK(I,J)                                            
            DL=MAX(USTAR*USTAR*TAVR(I,J)/(3.4335*TSTAB),5.)             
            OBUK(I,J)=DL*TSTAR/TSTAB                                    
            L=L+1                                                       
C                                                                       
C     FIND THE MIXING HEIGHT LEVEL K                                    
C                                                                       
            DO 10 K=1,NZ                                                
               KLEV=K-1                                                 
               IF(ZET(K).GT.ZMH) GOTO 20                                
 10         CONTINUE                                                    
C                                                                       
C     INTERPOLATE  WIND AND TEMPERATURES AT THE MIXING HEIGHT LEVEL     
C                                                                       
 20         DRATIO=(ZMH-ZET(KLEV))/(ZET(KLEV+1)-ZET(KLEV))              
C  ** U COMPONENT **                                                    
            U2=UX(I,J,KLEV+1)+UM(KLEV+1)                                
            U1=UX(I,J,KLEV)+UM(KLEV)                                    
            U=U1+(U2-U1)*DRATIO                                         
C  ** V COMPONENT **                                                    
            V2=VY(I,J,KLEV+1)+VM(KLEV+1)                                
            V1=VY(I,J,KLEV)+VM(KLEV)                                    
            V=V1+(V2-V1)*DRATIO                                         
            IF(NY.EQ.1) V=0.0                                           
C  ** W COMPONENT **                                                    
            W2=WZ(I,J,KLEV+1)                                           
            W1=WZ(I,J,KLEV)                                             
            W=W1+(W2-W1)*DRATIO                                         
C  ** POTENTIAL TEMPERATURE **                                          
            T2=POTT(I,J,KLEV+1)+TM(KLEV+1)                              
            T1=POTT(I,J,KLEV)+TM(KLEV)                                  
            T=T1+(T2-T1)*DRATIO                                         
C  ** LAPSE RATE ABOVE THE INVERSION DT+/DZ **                          
            DTPL=(TM(NZ)-T)/(ZET(NZ)-ZMH)                               
C  ** SURFACE TEMPERATURE  **                                           
            TS=TM(1)+POTT(I,J,1)                                        
C                                                                       
C           CALCULATE FORCING TERMS FOR THE BOUNDARY LAYER HEIGHT       
C           FOR STABLE (SMEDA) AND UNSTABLE (DEARDORFF) CONDITIONS      
C                                                                       
            IF(DL.LT.0.) THEN                                           
                WSTAR=(-9.8*USTAR*TSTAR*ZMH/TS)**0.333333               
               DNUM=2.2*(WSTAR**3+1.1*USTAR**3-3.3*USTAR**2*F*ZMH)      
               DENO=9.8*ZMH*ZMH*DTPL/TS+9.*WSTAR*WSTAR+7.2*USTAR*USTAR  
               ENT=DNUM/DENO                                            
                         ELSE                                           
               WSTAR=0.0                                                
               ENT=0.06*USTAR*USTAR*(1.-(3.3*ZMH*F/USTAR)**3)/(ZMH*F)   
            ENDIF                                                       
C                                                                       
C           CALCULATE THE RIGHT HAND SIDE IN DEARDORFFS RELATION        
C                                                                       
            DCDX(L)=-U*DCDX(L)-V*DCDY(L)+W+ENT                          
 30      CONTINUE                                                       
 40   CONTINUE                                                          
CX20786 CALL DOOUTX( 786 )                                              
CY20786 CALL DOOUTY( 786 )                                              
C                                                                       
C    MARCH IN TIME WITH LEAPFROG                                        
C                                                                       
      CALL LEAPFR(ISTEP,LOOP,DELTAT,HMIX,DCDX,STEPH)                    
CX40166 CALL SBOUTX (166)                                               
CY40166 CALL SBOUTY (166)                                               
C     CALL HORSMT(NX,NY,HMIX)                                           
C                                                                       
      RETURN                                                            
      END                                                               
C                                                                       
C **********************************************************************
C *       SUBROUTINE TO INITIALIZE THE BOUNDARY LAYER HEIGHT           *
C **********************************************************************
C                                                                       
      SUBROUTINE INITBL(NX,NY,ELEV,HMIX,H0)                             
      REAL HMIX(NX,NY),ELEV(NX,NY)                                      
CX30167 CALL SBINX (167)                                                
CY30167 CALL SBINY (167)                                                
CX10787 CALL DOINX( 787 )                                               
CY10787 CALL DOINY( 787 )                                               
      DO 20 J=1,NY                                                      
         DO 10 I=1,NX                                                   
            HMIX(I,J)=H0                                                
 10      CONTINUE                                                       
 20   CONTINUE                                                          
CX20788 CALL DOOUTX( 788 )                                              
CY20788 CALL DOOUTY( 788 )                                              
CX40168 CALL SBOUTX (168)                                               
CY40168 CALL SBOUTY (168)                                               
      RETURN                                                            
      END                                                               
C                                                                       
C   ********************************************************************
C   *  SUBROUTINE TO CALCULATE THE SURFACE LAYER HEIGHT AND GENERALLY  *
C   *  ALL SURFACE LAYER PARAMETERS SMOOTH THEM AND USE THEM AS INPUT  *
C   *  TO PRODUCE THE DIFFUSIVITY PROFILES FOR HEAT AND MOMENTUM (KZ)  *
C   ********************************************************************
C                                                                       
      SUBROUTINE SFCPAR(U,T,ZET,NZ,Z0,USTAR,TSTAR,DL,ZMH,TSL,TMES)      
      REAL U(*),T(*),ZET(*)                                             
CX30169 CALL SBINX (169)                                                
CY30169 CALL SBINY (169)                                                
C                                                                       
C     ZS IS THE SURFACE LAYER, A FRACTION OF THE BOUNDARY LAYER         
C                                                                       
      ZMH=MAX(ZMH,50.)                                                  
      ZS=MAX(TSL*ZMH,ZET(2))                                            
      Z0=MAX(Z0,0.00001)                                                
CX10789 CALL DOINX( 789 )                                               
CY10789 CALL DOINY( 789 )                                               
C                                                                       
C     FIND THE SURFACE LAYER HEIGHT                                     
C                                                                       
      DO 10 K=2,NZ                                                      
         KLEV=K-1                                                       
         IF(ZS.LE.ZET(K)) GO TO 20                                      
 10   CONTINUE                                                          
CX20790 CALL DOOUTX( 790 )                                              
CY20790 CALL DOOUTY( 790 )                                              
 20   CONTINUE                                                          
C                                                                       
C     FIND MEAN QUANTITIES IN THE SURFACE LAYER ACCORDING TO DEARDORFF  
C                                                                       
      DZET=ZS-Z0                                                        
      RATIO=(ZS/2.-Z0)/(ZET(KLEV+1)-Z0)                                 
      UMES=MAX(U(KLEV+1)*RATIO,0.005)                                   
      TMES=T(1)+(T(KLEV+1)-T(1))*RATIO                                  
C                                                                       
C     THE ANEMOMETER HEIGHT IS ZH OR IN THIS CASE THE FIRST VERTICAL    
C     LEVEL ABOVE THE GROUND. IF EVEN VERTICAL LAYERS ARE USED, ZH      
C     MUST NOT EXCEED 30 METERS. IN THIS CASE ASSIGN ZH=20.             
C                                                                       
      ZH=ZET(2)                                                         
C                                                                       
C     CALCULATE WIND AND TEMPERATURE AT ANEMOMETER HEIGHT               
C                                                                       
      UZH=MAX(ZH*U(2)/ZET(2),0.0001)                                    
      TZH=ZH*T(2)/ZET(2)                                                
C   ** SURFACE TEMPERATURE **                                           
      TS=T(1)                                                           
C                                                                       
C        CALCULATE THE MODEL'S LAPSE RATE AND SHEAR IN THE              
C        SURFACE LAYER. THE -0.0098 IS THE DRY ADIABAT.                 
C        CONVERT TO DEGREES K PER 100 METERS, AND CALCULATE THE         
C        STABILITY PARAMETER BETA FROM FORMULA (LLOYD)                  
C                                                                       
      DUDZ=UMES/DZET                                                    
      DTDZ=(TMES-TS)/DZET                                               
C                                                                       
      DTHDZ=100.*(DTDZ-0.0098)                                          
      IF(DTHDZ.LT.-5.) DTHDZ=-5.                                        
      BETA=1./(10.+DTHDZ)**2+.0025*DUDZ                                 
      BETA=1./SQRT(BETA)                                                
C                                                                       
C     THERE IS A CORRESPONDANCE BETWEEN BETA AND THE PASQUILL           
C     STABILITY CLASS (FUNCTION CLASS). THUS FROM BETA                  
C     CALCULATE THE MONIN-OBUKOV LENGTH THROUGH GOLDERS STABILITY       
C     DIAGRAM AS A FUNCTION OF ROUGHNESS LENGTH                         
C                                                                       
      DL=1./OVL(BETA,Z0)                                                
C                                                                       
C        SURFACE LAYER CALCULATIONS FOR THE ESTIMATION OF THE           
C        FRICTIONAL VELOCITY AND TURBULENT POTENTIAL TEMPERATURE        
C        UNDER DIFFERENT STABILITY CONDITIONS                           
C                                                                       
      CALL SURFAC(UZH,TZH,TS,ZH,Z0,DL,USTAR,TSTAR)                      
CX40170 CALL SBOUTX (170)                                               
CY40170 CALL SBOUTY (170)                                               
C                                                                       
      RETURN                                                            
      END                                                               
C                                                                       
C **********************************************************************
C *  ROUTINE THAT CALCULATES U*, AND T* IN THE  SURFACE LAYER.         *
C **********************************************************************
C                                                                       
      SUBROUTINE  SURFAC(UZH,TZH,TS,ZH,Z0,DL,USTAR,TSTAR)               
CX30171 CALL SBINX (171)                                                
CY30171 CALL SBINY (171)                                                
C                                                                       
C        IMPORTANT ROLE PLAY THE NONDIMENSIONAL LENGTH Z/L = ZOL        
C        AND THE SURFACE LAYER PARAMETERS ACCORDING TO STABILITY        
C        IF (DL) L<0 UNSTABLE,  L>0 STABLE  CONDITIONS.                 
C                                                                       
      IF(DL.LT.0.) THEN                                                 
C * * *    U N S T A B L E   C A S E   * * *                            
         ZHMPHI=(1.-15.*ZH/DL)**.25                                     
         Z0MPHI=(1.-15.*Z0/DL)**.25                                     
         Z0TPHI=(1.-9.*Z0/DL)**0.5                                      
         ZHTPHI=(1.-9.*ZH/DL)**0.5                                      
         P0=MAX(0.00001,(ZHMPHI+1.)*(Z0MPHI-1.))                        
         Q0=MAX(0.00001,(ZHTPHI+1.)*(Z0TPHI-1.))                        
         P=(ZHMPHI-1.)*(Z0MPHI+1.)/P0                                   
         Q=(ZHTPHI-1.)*(Z0TPHI+1.)/Q0                                   
         USTAR=0.35*UZH/(LOG(P)+2.*(ATAN(ZHMPHI)-ATAN(Z0MPHI)))         
         TSTAR=0.35*(TZH-TS)/(0.74*LOG(Q))                              
C                                                                       
C * * *   S T A B L E    O R   N E U T R A L   C A S E       * * *      
C                                                                       
                   ELSE                                                 
         USTAR=0.35*UZH/(LOG(ZH/Z0)+4.7*(ZH-Z0)/DL)                     
         TSTAR=0.35*(TZH-TS)/(0.74*LOG(ZH/Z0)+4.7*(ZH-Z0)/DL)           
      ENDIF                                                             
CX40172 CALL SBOUTX (172)                                               
CY40172 CALL SBOUTY (172)                                               
C                                                                       
      RETURN                                                            
      END                                                               
C                                                                       
C  *********************************************************************
C  *  THIS ROUTINE CALCULATES THE EDDY DIFFUSIVITY COEFFICIENTS        *
C  *  FOR HEAT AND MOMENTUM IN THE SURFACE LAYER AND THE TOP OF THE    *
C  *  SURFACE LAYERS, AND MATCHES THE DIFFUSIVITIES FROM THE TOP OF    *
C  *  SURFACE LAYERS TO THE TOP OF THE BOUNDARY LAYER (EKMAN LAYER)    *
C  *********************************************************************
C                                                                       
      SUBROUTINE BLSOLV(ZET,NZ,Z0,USTAR,DL,DZ,DKZM,DKZH,ZMH,TSL)        
      REAL ZET(1),DKZM(1),DKZH(1)                                       
CX30173 CALL SBINX (173)                                                
CY30173 CALL SBINY (173)                                                
C                                                                       
C     MINIMUM VALUES FOR THE DIFFUSIVITIES AT THE MODEL SURFACE         
C                                                                       
      DKZM(1)=DZ                                                        
      DKZH(1)=DZ                                                        
CX10791 CALL DOINX( 791 )                                               
CY10791 CALL DOINY( 791 )                                               
C                                                                       
      DO 10 K=2,NZ                                                      
C                                                                       
C        SURFACE LAYER KM AND KH CALCULATIONS                           
C                                                                       
         KE=K                                                           
         CALL SRFLAY(ZET,DKZM(K),DKZH(K),NZ,K,ZMH,DL,Z0,USTAR,          
     *   DZ,TSL,ZS,DKSM,DKZSM,DKSH,DKZSH,KLEV)                          
         IF(DKSM.GT.0.) GOTO 20                                         
 10   CONTINUE                                                          
CX20792 CALL DOOUTX( 792 )                                              
CY20792 CALL DOOUTY( 792 )                                              
C                                                                       
C        EKMAN LAYER KM AND KH CALCULATIONS                             
C                                                                       
 20   CONTINUE                                                          
      KE=KE+KLEV                                                        
CX10793 CALL DOINX( 793 )                                               
CY10793 CALL DOINY( 793 )                                               
      DO 30 K=KE,NZ                                                     
         CALL EKMLAY(ZET(K),DKZM(K),DKZH(K),ZMH,DZ,ZS,                  
     *   DKSM,DKZSM,DKSH,DKZSH)                                         
 30   CONTINUE                                                          
CX20794 CALL DOOUTX( 794 )                                              
CY20794 CALL DOOUTY( 794 )                                              
C                                                                       
C      SMOOTH THE DIFFUSIVITIES VERTICALLY                              
C                                                                       
       CALL SMTH(DKZM,ZET,NZ)                                           
       CALL SMTH(DKZH,ZET,NZ)                                           
CX40174 CALL SBOUTX (174)                                               
CY40174 CALL SBOUTY (174)                                               
C                                                                       
      RETURN                                                            
      END                                                               
C                                                                       
C **********************************************************************
C *  ROUTINE THAT CALCULATES DIFFUSIVITIES IN THE SURFACE LAYER.       *
C *  ALSO THE ROUTINE CALCULATES THE TOP OF THE SURFACE LAYER AND IF   *
C *  ZS>ZET IT CALCULATES K AND DK/DZ AT ZET=ZS FOR THE MATCHING COND. *
C **********************************************************************
C                                                                       
      SUBROUTINE  SRFLAY(ZET,DKZM,DKZH,NZ,K,ZMH,DL,Z0,USTAR,DZ,         
     *TSL,ZS,DKSM,DKZSM,DKSH,DKZSH,KL)                                  
      REAL ZET(*)                                                       
CX30175 CALL SBINX (175)                                                
CY30175 CALL SBINY (175)                                                
C                                                                       
C        IMPORTANT ROLE PLAY THE NONDIMENSIONAL LENGTH Z/L = ZOL        
C        AND THE SURFACE LAYER PARAMETERS ACCORDING TO STABILITY        
C        IF (DL) L<0 UNSTABLE,  L>0 STABLE  PROFILES.                   
C                                                                       
      DKSM=-1.0                                                         
      KL=1                                                              
      DKZSM=0.0                                                         
      ZOL=ZET(K)/DL                                                     
      ZS=MAX(TSL*ZMH,ZET(2))                                            
      IF(DL.LT.0.) THEN                                                 
C                                                                       
C * * *    U N S T A B L E   P R O F I L E   * * *                      
C                                                                       
C     IF THE TOP ZS OF THE SURFACE LAYER > Z THEN CALCULATE             
C     THE MATCHING CONDITIONS AND SET FLAG DKSM><0                      
C                                                                       
         IF(ZOL.LT.-5.) THEN                                            
C                                                                       
C * * *   W E A K L Y  U N S T A B L E  * * *                           
C                                                                       
C         K=0.35, 0.078 AN EMPIRICAL CONSTANT, THE QUBIC ROOT           
C         OF THEIR PRODUCT=0.6064, 2.162 ANOTHER CONSTANT,PROD3=1.835   
C         BOTH PRODUCTS MULTIPLIED BU 4/3 TO YIELD THE DERIVATIVES      
C                                                                       
            DKZM=0.6064*USTAR*ZET(K)*ABS(ZOL)**0.3333                   
            DKZH=1.835*USTAR*ZET(K)*ABS(ZOL)**0.3333                    
            IF(ZS.LT.ZET(K)) THEN                                       
               DKSM=0.6064*USTAR*ZS*ABS(ZS/DL)**0.3333                  
               DKSH=1.835*USTAR*ZS*ABS(ZS/DL)**0.3333                   
               DKZSM=0.8085*USTAR*ABS(-ZS/DL)**0.3333                   
               DKZSH=2.446*USTAR*ABS(-ZS/DL)**0.3333                    
               IF(ABS(ZS-ZET(K)).GT.ABS(ZS-ZET(K-1))) KL=0              
            ENDIF                                                       
                        ELSE                                            
C                                                                       
C * * *   S T R O N G L Y  U N S T A B L E * * *                        
C                                                                       
C         0.35 IS THE VON KARMAN CONST AND 0.74 A CONSTANT              
C         DETERMINED BY BUSINGER. 0.473 IS THEIR RATIO.                 
C                                                                       
            DKZM=.35*USTAR*ZET(K)*(1.-15.*ZOL)**0.25                    
            DKZH=.473*USTAR*ZET(K)*(1.-9.*ZOL)**0.5                     
            IF(ZS.LT.ZET(K)) THEN                                       
               DKSM=.35*USTAR*ZS*(1.-15.*ZS/DL)**.25                    
               DKSH=.473*USTAR*ZS*(1.-9.*ZS/DL)**.5                     
               DKZSM=.35*USTAR*((1.-18.75*ZS/DL)/(1.-15.*ZS/DL)**.75)   
               DKZSH=.473*USTAR*((1.-13.5*ZS/DL)/(1.-9.*ZS/DL)**.5)     
               IF(ABS(ZS-ZET(K)).GT.ABS(ZS-ZET(K-1))) KL=0              
            ENDIF                                                       
         ENDIF                                                          
                   ELSE                                                 
C                                                                       
C * * *   S T A B L E    P R O F I L E     * * *                        
C                                                                       
         DKZM=.35*USTAR*ZET(K)/(1.+4.7*ZOL)                             
         DKZH=.35*USTAR*ZET(K)/(0.74+4.7*ZOL)                           
         IF(ZS.LT.ZET(K)) THEN                                          
            DKSM=.35*USTAR*ZS/(1.+4.7*ZS/DL)                            
            DKSH=.35*USTAR*ZS/(0.74+4.7*ZS/DL)                          
            DKZSM=.35*USTAR/(1.+4.7*ZS/DL)**2                           
            DKZSH=.35*USTAR/(0.74+4.7*ZS/DL)**2                         
            IF(ABS(ZS-ZET(K)).GT.ABS(ZS-ZET(K-1)))  KL=0                
         ENDIF                                                          
      ENDIF                                                             
      DKZM=MAX(DKZM,DZ)                                                 
      DKZH=MAX(DKZH,DZ)                                                 
CX40176 CALL SBOUTX (176)                                               
CY40176 CALL SBOUTY (176)                                               
C                                                                       
      RETURN                                                            
      END                                                               
C                                                                       
C **********************************************************************
C *  THIS SUBROUTINE DETERMINES THE VALUES OF KZM AND KZH IN THE EKMAN *
C *  LAYER    IN THE MANNER SUGGESTED BY O'BRIEN(1970).                *
C **********************************************************************
C                                                                       
      SUBROUTINE EKMLAY(ZET,DKZM,DKZH,ZMH,DZ,ZS,DKSM,DKZSM,DKSH,DKZSH)  
CX30177 CALL SBINX (177)                                                
CY30177 CALL SBINY (177)                                                
C                                                                       
      DKE=DZ                                                            
      ZE=ZMH                                                            
      DELZ=ZET-ZE                                                       
      IF(DELZ.GT.0.) THEN                                               
         DKZM=DZ                                                        
         DKZH=DZ                                                        
CX40178 CALL SBOUTX (178)                                               
CY40178 CALL SBOUTY (178)                                               
         RETURN                                                         
      ENDIF                                                             
      DELZ=DELZ*DELZ                                                    
      DZES=ZE-ZS                                                        
      DKSMKE=DKSM-DKE                                                   
      DKSHKE=DKSH-DKE                                                   
C                                                                       
C        O'BRIEN'S FORMULATION                                          
C                                                                       
      DKZM=DKE+DELZ/(DZES**2.)*(DKSMKE+(ZET-ZS)*(DKZSM+2.*DKSMKE/DZES)) 
      DKZM=MAX(DKZM,DZ)                                                 
      DKZH=DKE+DELZ/(DZES**2.)*(DKSHKE+(ZET-ZS)*(DKZSH+2.*DKSHKE/DZES)) 
      DKZH=MAX(DKZH,DZ)                                                 
CX40178 CALL SBOUTX (178)                                               
CY40178 CALL SBOUTY (178)                                               
C                                                                       
      RETURN                                                            
      END                                                               
C                                                                       
C **********************************************************************
C *        BOUNDARY LAYER SET FOR THE MEAN WIND AND TEMPERATURE        *
C **********************************************************************
C                                                                       
      SUBROUTINE DKZMN(POTT,WM,ZET,DKZ,DZMIN,Z0,USTAR,DL,KLAS,ZMH,F,NZ) 
      DIMENSION DKZ(*),POTT(*),ZET(*)                                   
      COMPLEX WM(*)                                                     
CX30179 CALL SBINX (179)                                                
CY30179 CALL SBINY (179)                                                
      U=ABS(WM(2))                                                      
      CALL BLM(U,POTT,ZET,NZ,Z0,USTAR,DL,DZMIN,DKZ,KLAS,ZMH,F)          
CX40180 CALL SBOUTX (180)                                               
CY40180 CALL SBOUTY (180)                                               
      RETURN                                                            
      END                                                               
C                                                                       
C **********************************************************************
C *    ANOTHER BOUNDARY LAYER SOLVER FOR THE   WIND AND TEMPERATURE    *
C *    U,T ARE UTILITY VECTORS FOR DATA MANIPULATIONS. (HELP,HELPA)    *
C *    POTT,UX,VY ARE THE PRTURBATION TEMPERATURE AND WINDS, ZET IS    *
C *    THE GEOMETRIC HEIGHT, DKZ IS THE PERTURBATION EDDY DIFFUSIVITY  *
C *    DZMIN THE MINIMUM DIFFUSIVITY SPECIFIED IN THE DATA, Z0 IS THE  *
C *    TERRAIN ROUGHNESS, ELEV IS THE TOPOGRAPHY, NX,NY,NZ ARE THE     *
C *    DOMAIN GRID POINTS HMIX IS THE MIXING HEIGHT HBL IS THE HEIGHT  *
C *    OF THE BOUNDARY LAYER, OBUK IS THE MONIN OBUKOV LENGTH, USTR IS *
C *    FRICTIONAL VELOCITY AND  TAVR IS THE GOLDER STABILITY REGIME    *
C *    THE MIXING HEIGHTS HERE ARE CALCULATED DIAGNOSTICALLY           *
C **********************************************************************
C                                                                       
      SUBROUTINE DKZP(U,T,TM,UM,VM,POTT,UX,VY,ZET,DKZ,DZMIN,            
     *Z0,ELEV,NX,NY,NZ,HMIX,TAVR,OBUK,USTR,VDEP,NSMT,F,DLM,AN,BN,CN)    
C                                                                       
      DIMENSION ZET(*),U(*),Z0(NX,NY),ELEV(NX,NY),HMIX(NX,NY),TM(*)     
      REAL OBUK(NX,NY),USTR(NX,NY),VDEP(NX,NY),TAVR(NX,NY),VM(*),UM(*)  
      REAL UX(NX,NY,NZ),VY(NX,NY,NZ),POTT(NX,NY,NZ),DKZ(NX,NY,NZ),T(*)  
      REAL AN(*),BN(*),CN(*)                                            
CX30181 CALL SBINX (181)                                                
CY30181 CALL SBINY (181)                                                
CX10795 CALL DOINX( 795 )                                               
CY10795 CALL DOINY( 795 )                                               
      DO 40 J=1,NY                                                      
         DO 30 I=1,NX                                                   
C                                                                       
C           CALCULATE ROUGHNES LENGTH BY USING THE  FRICTION            
C           VELOCITY ONLY FOR LAKE (ELEV<0.)                            
C                                                                       
            ZNOT=Z0(I,J)                                                
            IF(ELEV(I,J).LT.0) THEN                                     
               USTAR=MAX(USTR(I,J),0.005)                               
               ZNOT=3.905E-5/USTAR+1.6046E-3*USTAR**2-1.747E-4          
               Z0(I,J)=ZNOT                                             
            ENDIF                                                       
C                                                                       
C           FILL VECTORS WITH PERTURBATION WIND AND TEMPERATURE         
C                                                                       
C *****   REMEMBER  K(MESO)=K(MESO+SYNOP)-K(SYNOP)                      
C                                                                       
            DO 10 K=1,NZ                                                
               IF(I.EQ.1.OR.I.EQ.NX) THEN                               
                  TX=0.5*POTT(I,J,K)                                    
                  WUX=0.5*UX(I,J,K)                                     
                  WVX=0.5*VY(I,J,K)                                     
                                     ELSE                               
                  TX=0.25*(POTT(I-1,J,K)+POTT(I+1,J,K))                 
                  WUX=0.25*(UX(I-1,J,K)+UX(I+1,J,K))                    
                  WVX=0.25*(VY(I-1,J,K)+VY(I+1,J,K))                    
               ENDIF                                                    
               IF(J.EQ.1.OR.J.EQ.NY) THEN                               
                  TY=0.5*POTT(I,J,K)                                    
                  WUY=0.5*UX(I,J,K)                                     
                  WVY=0.5*VY(I,J,K)                                     
                                     ELSE                               
                  TY=0.25*(POTT(I,J-1,K)+POTT(I,J+1,K))                 
                  WUY=0.25*(UX(I,J-1,K)+UX(I,J+1,K))                    
                  WVY=0.25*(VY(I,J-1,K)+VY(I,J+1,K))                    
               ENDIF                                                    
C                                                                       
C    ADD MEAN FIELDS AND CALCULATE TOTAL WIND                           
C                                                                       
               XW=(UX(I,J,K)+WUX+WUY)/2.+UM(K)                          
               YW=(VY(I,J,K)+WVX+WVY)/2.+VM(K)                          
               U(K)=SQRT(XW*XW+YW*YW)                                   
               T(K)=(POTT(I,J,K)+TX+TY)/2.+TM(K)                        
 10         CONTINUE                                                    
            WIND=U(2)                                                   
C                                                                       
C     CALL THE BOUNDARY LAYER SOLVER                                    
C                                                                       
            CALL BLM(WIND,T,ZET,NZ,ZNOT,USTAR,DL,DZMIN,U,               
     *      KLAS,ZMH,F)                                                 
C                                                                       
C     DUMP VERTICAL DISTRIBUTION OF KZ                                  
C                                                                       
            DO 20 K=1,NZ                                                
               DKZ(I,J,K)=U(K)                                          
 20         CONTINUE                                                    
C                                                                       
C           STORE DRY DEPOSITION VELOCITIES IN STABLE CONDITIONS        
C                                                                       
            IF(KLAS.GE.4) THEN                                          
               VDEP(I,J)=USTAR/500.                                     
            ENDIF                                                       
            IF(KLAS.LT.4) THEN                                          
C                                                                       
C           STORE DRY DEPOSITION VELOCITIES IN UNSTABLE CONDITIONS      
C                                                                       
               IF(KLAS.EQ.3) THEN                                       
                  VDEP(I,J)=USTAR*(1.+(-300/DL)**0.6666667)/500.        
                             ELSE                                       
C                 VERY UNSTABLE CONDITIONS                              
                  VDEP(I,J)=USTAR*0.0009*(-ZMH/DL)**0.6666667           
               ENDIF                                                    
            ENDIF                                                       
C                                                                       
C           DUMP ALL HORIZONTAL BOUNDARY LAYER PERAMETERS BACK          
C                                                                       
            OBUK(I,J)=DL                                                
            HMIX(I,J)=ZMH                                               
            USTR(I,J)=USTAR                                             
            TAVR(I,J)=FLOAT(KLAS)                                       
 30      CONTINUE                                                       
 40   CONTINUE                                                          
CX20796 CALL DOOUTX( 796 )                                              
CY20796 CALL DOOUTY( 796 )                                              
      CALL SMOOTH(DKZ,NX,NY,NZ)                                         
      CALL HORIMS(NX,NY,VDEP,DLM,U,T,AN,BN,CN)                          
CX40182 CALL SBOUTX (182)                                               
CY40182 CALL SBOUTY (182)                                               
      RETURN                                                            
      END                                                               
C                                                                       
C **********************************************************************
C *         B O U N D A R Y    L A Y E R    S O L V E R                *
C *    THIS ROUTINE IS A BOUNDARY LAYER SOLVER USING THE K-DIFFUSIVITY *
C *    THEORY.  GIVEN THE VERTICAL WIND AND TEMPERATURE DISTRIBUTION   *
C *    AND SURFACE CHARACTERISTICS, IT CALCULATES  VERTICAL            *
C *    DISTRIBUTION OF THE EDDY  DIFFUSSIVITY COEFFICIENTS   KZ (DKZ)  *
C *    DZ=MINIMUM OF EDDY DIFFUSIVITY (INPUT) , KLAS=STABILITY CLASS   *
C *    (OUTPUT), Z0=ROUGHNESS LENGTH (INPUT/OUTPUT), ZET U AND POTT    *
C *    (INPUTS) HEIGHT Z(M), WIND (M/S) AND  TEMPERATURE PROFILES      *
C *    RESPECTIVELY, H=MIXING HEIGHT(M), USTAR= FRICTION VELOCITY      *
C *    AND MONIN-OBUKHOV LENGTH DL (M) (OUTPUTS) (F=CORIOLIS=10E-4)    *
C **********************************************************************
C                                                                       
      SUBROUTINE BLM(U,POTT,ZET,NZ,Z0,USTAR,DL,DZ,DKZ,KLAS,ZMH,F)       
      REAL POTT(*),ZET(*),DKZ(*)                                        
CX30183 CALL SBINX (183)                                                
CY30183 CALL SBINY (183)                                                
C                                                                       
C      THE NEUTRAL CASE IS ACCOMONDATED BY DEFINING DL=-1.E5            
C                                                                       
      DL=-1.E5                                                          
      Z0=MAX(Z0,0.00001)                                                
C                                                                       
C    WIND AT ANEMOMETER HEIGHT ZH, (10 M  FROM THE GROUND.)             
C                                                                       
      H=0.                                                              
      ZH=10.                                                            
      UZ0=0.                                                            
      UZ1=0.                                                            
      UMES=ZH*U/ZET(2)                                                  
      UMES=MAX(UMES,0.05)                                               
      DKZ(1)=DZ                                                         
CX10797 CALL DOINX( 797 )                                               
CY10797 CALL DOINY( 797 )                                               
C                                                                       
      DO 30 K=2,NZ                                                      
         IF(K.EQ.2) THEN                                                
            DZET=ZET(K)-Z0                                              
            DUDZ=U/DZET                                                 
                    ELSE                                                
            DZET=ZET(K)-ZET(K-1)                                        
            UZ1=UMES*LOG(ZET(K)/Z0)/LOG(ZH/Z0)                          
            DUDZ=ABS(UZ1-UZ0)/DZET                                      
         ENDIF                                                          
C                                                                       
C        CALCULATE THE MODEL'S LAPSE RATE AND SHEAR IN THE              
C        SURFACE LAYER. THE -0.0098 IS THE DRY ADIABAT.                 
C        CONVERT TO K/100M                                              
C        UZZ IS A NEUTRAL ESTIMATE OF THE WIND SPEED WITH HEIGHT        
C                                                                       
         DTDZ=100.*((POTT(K)-POTT(K-1))/DZET-0.0098)                    
         IF(DTDZ.LT.-5.) DTDZ=-5.                                       
C                                                                       
C        SINCE DUDZ IS THE SHEAR IN UNKOWN STABILITY CONDITIONS USE     
C        SUCESSIVE CORECTIONS (LCOR<10) TO OBTAIN THE CORRECT           
C        MONIN-OBUKHOV LENGTH WHICH CORRESPONDS TO A STABILITY          
C        CORRECTED SHEAR DUDZ.                                          
C        DL IS THEN CALCULATED FROM THE STABILITY PARAMETER BETA        
C                                                                       
         DUMB=DUDZ                                                      
         DO 10 LCOR=1,10                                                
            DLN=DL                                                      
            BETA=1./(10.+DTDZ)**2+.0025*DUDZ                            
            BETA=1./SQRT(BETA)                                          
            DL=1./OVL(BETA,Z0)                                          
            ZOL=ZET(K)/DL                                               
C                                                                       
C        IF IN FIRST LAYER THEN NO NEED TO CORRECT SHEAR PHI(Z/L)       
C                                                                       
            IF(K.EQ.2) GO TO 20                                         
C                                                                       
C        MONIN-OBUKHOV LENGTH CONVERGENCE CRITERION                     
C                                                                       
            TOL=ABS((DLN-DL)/DL)                                        
            IF(TOL.LE.0.01) GO TO 20                                    
            IF(DL.LT.0.) THEN                                           
               DUDZ=DUMB/(1.-15.*ZOL)**(0.25)                           
                         ELSE                                           
               DUDZ=DUMB*(1.+4.7*ZOL)                                   
            ENDIF                                                       
 10      CONTINUE                                                       
CX20798 CALL DOOUTX( 798 )                                              
CY20798 CALL DOOUTY( 798 )                                              
C                                                                       
C        FIND STABILITY CLASS IN THE GOLDER DIAGRAM                     
C                                                                       
 20      CONTINUE                                                       
         UZ0=UZ1                                                        
         KLAS = KLASS(BETA)                                             
C                                                                       
C        SURFACE LAYER CALCULATIONS                                     
C                                                                       
         KE=K                                                           
         CALL SRFCLR(POTT,ZET,DKZ(K),NZ,K,ZMH,DL,ZH,Z0,USTAR,UMES,DZ,   
     *   ZS,DKS,DKZS,KLEV,H,F)                                          
         IF(DKS.GT.0.) GOTO 40                                          
 30   CONTINUE                                                          
C                                                                       
C        EKMAN LAYER CALCULATIONS                                       
C                                                                       
 40   CONTINUE                                                          
      KE=KE+KLEV                                                        
CX10799 CALL DOINX( 799 )                                               
CY10799 CALL DOINY( 799 )                                               
      DO 50 K=KE,NZ                                                     
         CALL EKMNLR(ZET(K),DKZ(K),ZMH,DZ,ZS,DKS,DKZS)                  
 50   CONTINUE                                                          
CX20800 CALL DOOUTX( 800 )                                              
CY20800 CALL DOOUTY( 800 )                                              
C                                                                       
C      SMOOTH THE DIFFUSIVITIES                                         
C                                                                       
       CALL SMTH(DKZ,ZET,NZ)                                            
CX40184 CALL SBOUTX (184)                                               
CY40184 CALL SBOUTY (184)                                               
C                                                                       
      RETURN                                                            
      END                                                               
C                                                                       
C **********************************************************************
C *     ROUTINE TO CALCULATE THE TURBOULENT MIXING HEIGHT FROM THE     *
C *     VERTICAL DISTRIBUTION OF THE POTENTIAL TEMPERATURE             *
C *     H, CONVECTIVELY INDUCED MIXING HEIGHT, (OUTPUT)                *
C *     ZHTMIX , MECHANICALLY INDUCED MIXING HEIGHT (INPUT)            *
C *     POTT(*) IS POTENTIAL TEMPERATURE, ZET(*) IS, HEIGHT (INPUTS)   *
C **********************************************************************
C                                                                       
      SUBROUTINE MIXHGT(POTT,ZET,NZ,ZMH,H)                              
                                                                        
      REAL POTT(1),ZET(1)                                               
CX30185 CALL SBINX (185)                                                
CY30185 CALL SBINY (185)                                                
C                                                                       
C     COMPUTE THE COVECTIVE MIXING HEIGHT IF THERE IS ANY               
C     FIRST FIND THE SURFACE BASED INVERSION                            
C                                                                       
      KTOP=1                                                            
CX10801 CALL DOINX( 801 )                                               
CY10801 CALL DOINY( 801 )                                               
      DO 20 K=2,NZ                                                      
         DT=POTT(K)-POTT(K-1)                                           
         IF(DT) 30,30,10                                                
 10      KTOP=K                                                         
 20   CONTINUE                                                          
CX20802 CALL DOOUTX( 802 )                                              
CY20802 CALL DOOUTY( 802 )                                              
C                                                                       
 30   IF(ZET(KTOP).GT.ZMH) THEN                                         
         H=MIN(ZMH,2000.)                                               
CX40186 CALL SBOUTX (186)                                               
CY40186 CALL SBOUTY (186)                                               
         RETURN                                                         
      ENDIF                                                             
C                                                                       
C    FIND THE HEIGHT AT WHICH A DRY ADIABAT FROM THE HEIGHT ZET(KTOP)   
C    CROSSES  THE MODEL'S LAPSE RATE. ASSIGN THIS HEIGHT AS THE         
C    MIXING HEIGHT H IF IT IS GREATER THAN ZMH.                         
C                                                                       
      ITS=0                                                             
      IF(KTOP.EQ.NZ) ITS=NZ                                             
      KK=KTOP+1                                                         
CX10803 CALL DOINX( 803 )                                               
CY10803 CALL DOINY( 803 )                                               
      DO 50 K=KK,NZ                                                     
         KKTOP=K                                                        
         DT=POTT(K)-POTT(KTOP)                                          
         IF(DT) 40,40,60                                                
 40      IF(K.EQ.NZ) ITS=NZ                                             
 50   CONTINUE                                                          
CX20804 CALL DOOUTX( 804 )                                              
CY20804 CALL DOOUTY( 804 )                                              
C                                                                       
 60   IF(ITS.EQ.NZ)  THEN                                               
         H=1600.                                                        
CX40186 CALL SBOUTX (186)                                               
CY40186 CALL SBOUTY (186)                                               
         RETURN                                                         
      ENDIF                                                             
C                                                                       
C     INVERSION HEIGHT                                                  
C                                                                       
      H=(ZET(KKTOP)-ZET(KKTOP-1))*(POTT(KTOP)-POTT(KKTOP-1))/           
     *(POTT(KKTOP)-POTT(KKTOP-1)) + ZET(KKTOP-1)                        
CX40186 CALL SBOUTX (186)                                               
CY40186 CALL SBOUTY (186)                                               
      RETURN                                                            
      END                                                               
C                                                                       
C  *********************************************************************
C  *  FUNCTION THAT DETERMINES THE ATMOSPHERIC STABILLITY CLASS        *
C  *  (PASQUILL-GIFFORD) FROM THE STABILITY PARAMETER (BETA).          *
C  *********************************************************************
C                                                                       
      FUNCTION KLASS(BETA)                                              
CX30187 CALL SBINX (187)                                                
CY30187 CALL SBINY (187)                                                
      KLASS = 6                                                         
      IF(BETA.LE.11.25) KLASS = 5                                       
      IF(BETA.LE. 9.50) KLASS = 4                                       
      IF(BETA.LE. 8.75) KLASS = 3                                       
      IF(BETA.LE. 8.00) KLASS = 2                                       
      IF(BETA.LE. 7.00) KLASS = 1                                       
CX40188 CALL SBOUTX (188)                                               
CY40188 CALL SBOUTY (188)                                               
      RETURN                                                            
      END                                                               
C                                                                       
C **********************************************************************
C *    THIS FUNCTION COMPUTES THE INVERSE OF THE MONIN-OBUKHOV LENGTH  *
C *    USING GOLDER'S TABLES OF ROUGHNESS LENGTH VERSUS THE PARAMETER  *
C *    BETA WHICH IS STABILITY DEPENDENT (DT/DZ AND DU/DZ)             *
C **********************************************************************
C                                                                       
      FUNCTION OVL(BETA,Z0)                                             
CX30189 CALL SBINX (189)                                                
CY30189 CALL SBINY (189)                                                
C                                                                       
      IF(BETA.GT.8.0) GO TO 1                                           
      SLOPE=0.0156-0.0072*(BETA-7.)                                     
      XL=0.0540*(BETA-8.33)+SLOPE*LOG(2.*Z0)                            
      OVL=MIN(XL,-0.003)                                                
CX40190 CALL SBOUTX (190)                                               
CY40190 CALL SBOUTY (190)                                               
      RETURN                                                            
  1   IF(BETA.GT.8.75) GO TO 2                                          
      SLOPE=0.0084-0.0085*(BETA-8.)                                     
      XL=0.0213*(BETA-8.84)+SLOPE*LOG(2.*Z0)                            
      OVL=MIN(XL,-0.0001)                                               
CX40190 CALL SBOUTX (190)                                               
CY40190 CALL SBOUTY (190)                                               
      RETURN                                                            
  2   IF(BETA.GT.9.02) GO TO 3                                          
      SLOPE=0.0019-0.0070*(BETA-8.75)                                   
      XL=0.0074*(BETA-9.02)+SLOPE*LOG(2.*Z0)                            
      OVL=MIN(XL,-0.00001)                                              
CX40190 CALL SBOUTX (190)                                               
CY40190 CALL SBOUTY (190)                                               
      RETURN                                                            
  3   IF(BETA.GT.9.5) GO TO 4                                           
      SLOPE=-0.0029*(BETA-9.02)                                         
      XL=0.0031*(BETA-9.02)+SLOPE*LOG(2.*Z0)                            
      OVL=MAX(XL,0.00001)                                               
CX40190 CALL SBOUTX (190)                                               
CY40190 CALL SBOUTY (190)                                               
      RETURN                                                            
  4   IF(BETA.GT.11.25) GO TO 5                                         
      SLOPE=-0.0014-0.0040*(BETA-9.5)                                   
      XL=0.0083*(BETA-9.32)+SLOPE*LOG(2.*Z0)                            
      OVL=MAX(XL,0.0001)                                                
CX40190 CALL SBOUTX (190)                                               
CY40190 CALL SBOUTY (190)                                               
      RETURN                                                            
  5   IF(BETA.GT.12.375) GO TO 6                                        
      SLOPE=-0.0084-0.0069*(BETA-11.25)                                 
      XL=0.0083*(BETA-9.32)+SLOPE*LOG(2.*Z0)                            
      OVL=MAX(XL,0.004)                                                 
CX40190 CALL SBOUTX (190)                                               
CY40190 CALL SBOUTY (190)                                               
      RETURN                                                            
  6   SLOPE=-0.0162-0.0069*(BETA-12.375)                                
      XL=0.0083*(BETA-9.32)+SLOPE*LOG(2.*Z0)                            
      OVL=MAX(XL,0.00667)                                               
CX40190 CALL SBOUTX (190)                                               
CY40190 CALL SBOUTY (190)                                               
      RETURN                                                            
      END                                                               
C                                                                       
C **********************************************************************
C *  ROUTINE THAT CALCULATES DIFFUSIVITIES IN THE SURFACE LAYER.       *
C *  ALSO THE ROUTINE CALCULATES THE TOP OF THE SURFACE LAYER AND IF   *
C *  ZS>ZET IT CALCULATES K AND DK/DZ AT ZET=ZS FOR THE MATCHING COND. *
C **********************************************************************
C                                                                       
      SUBROUTINE  SRFCLR(POTT,ZET,DKZ,NZ,K,ZMH,DL,ZH,Z0,USTAR,          
     *UMES,DZ,ZS,DKS,DKZS,KLEV,H,F)                                     
      REAL POTT(1),ZET(1)                                               
CX30191 CALL SBINX (191)                                                
CY30191 CALL SBINY (191)                                                
C                                                                       
C        IMPORTANT ROLE PLAY THE NONDIMENSIONAL LENGTH Z/L = ZOL        
C        AND THE SURFACE LAYER PARAMETERS ACCORDING TO STABILITY        
C        IF (DL) L<0 UNSTABLE,  L>0 STABLE  PROFILES.                   
C                                                                       
      DKS=-1.0                                                          
      KLEV=1                                                            
      DKZS=0.0                                                          
      ZOL=ZET(K)/DL                                                     
      IF(DL.LT.0.) THEN                                                 
C                                                                       
C * * *    U N S T A B L E   P R O F I L E   * * *                      
C                                                                       
         ZHPHI=(1.-15.*ZH/DL)**.25                                      
         Z0PHI=(1.-15.*Z0/DL)**.25                                      
         USTAR=0.35*UMES/(LOG(ZH/Z0)+LOG(((Z0PHI**2+1.)*(Z0PHI+1.)**2   
     *   )/((ZHPHI**2+1.)*(ZHPHI+1.)**2))+2.*(ATAN(ZHPHI)-ATAN(Z0PHI))) 
         IF(K.EQ.2) THEN                                                
            ZMH=0.4*(USTAR/F)**1.5/SQRT(-DL)                            
            CALL MIXHGT(POTT,ZET,NZ,ZMH,H)                              
                    ELSE                                                
            ZMH=0.4*USTAR/F                                             
         ENDIF                                                          
         IF(H.LT.50)  CALL MIXHGT(POTT,ZET,NZ,ZMH,H)                    
         IF(H.LT.2000.0.AND.H.GT.50) THEN                               
            ZMH=H + 100.                                                
                                     ELSE                               
            ZMH=MIN(2000.,ZMH) + 100.                                   
         ENDIF                                                          
         ZS=0.1*ZMH                                                     
C                                                                       
C     IF THE TOP ZS OF THE SURFACE LAYER > Z THEN CALCULATE             
C     THE MATCHING CONDITIONS AND SET FLAG DKS><0                       
C                                                                       
         IF(ZOL.LT.-5.) THEN                                            
C                                                                       
C * * *   W E A K L Y  U N S T A B L E  * * *                           
C                                                                       
CFACTOR=1.143                                                           
            DKZ=0.6064*USTAR*ZET(K)*ABS(ZOL)**0.3333                    
            IF(ZS.LT.ZET(K)) THEN                                       
               DKS=0.6064*USTAR*ZS*ABS(ZS/DL)**0.3333                   
               DKZS=0.8085*USTAR*ABS(-ZS/DL)**0.3333                    
               IF(ABS(ZS-ZET(K)).GT.ABS(ZS-ZET(K-1))) KLEV=0            
            ENDIF                                                       
                        ELSE                                            
C                                                                       
C * * *   S T R O N G L Y  U N S T A B L E * * *                        
C                                                                       
            DKZ=.35*USTAR*ZET(K)*((1.-15.*ZOL)**0.25)                   
            IF(ZS.LT.ZET(K)) THEN                                       
               DKS=.35*USTAR*ZS*(1.-15.*ZS/DL)**.25                     
               DKZS=.35*USTAR*((1.-18.75*ZS/DL)/(1.-15.*ZS/DL)**.75)    
               IF(ABS(ZS-ZET(K)).GT.ABS(ZS-ZET(K-1))) KLEV=0            
            ENDIF                                                       
         ENDIF                                                          
                   ELSE                                                 
C                                                                       
C * * *   S T A B L E    P R O F I L E     * * *                        
C                                                                       
         USTAR=0.35*UMES/(LOG(ZH/Z0)+4.7*(ZH-Z0)/DL)                    
         ZMH=0.4*SQRT(USTAR*DL/F)                                       
         ZHTMAX=0.4*USTAR/F                                             
         ZMH=MAX(ZHTMAX,ZMH)                                            
         ZMH=MIN(2000.,ZMH)                                             
         DKZ=.4*USTAR*ZET(K)/(1.+4.7*ZOL)                               
         ZS=0.1*ZMH                                                     
         IF(ZS.LT.ZET(K)) THEN                                          
            DKS=.35*USTAR*ZS/(1.+4.7*ZS/DL)                             
            DKZS=.35*USTAR/(1.+4.7*ZS/DL)**2.                           
            IF(ABS(ZS-ZET(K)).GT.ABS(ZS-ZET(K-1)))  KLEV=0              
         ENDIF                                                          
      ENDIF                                                             
      DKZ=MAX(DKZ,DZ)                                                   
CX40192 CALL SBOUTX (192)                                               
CY40192 CALL SBOUTY (192)                                               
C                                                                       
      RETURN                                                            
      END                                                               
C                                                                       
C **********************************************************************
C *  THIS SUBROUTINE DETERMINES THE VALUES OF KZ IN THE EKMAN LAYER    *
C *    IN THE MANNER SUGGESTED BY O'BRIEN(1970).                       *
C **********************************************************************
C                                                                       
      SUBROUTINE EKMNLR(ZET,DKZ,ZMH,DZ,ZS,DKS,DKZS)                     
CX30193 CALL SBINX (193)                                                
CY30193 CALL SBINY (193)                                                
C                                                                       
      DKE=DZ                                                            
      ZE=ZMH                                                            
CGAO      AKD=DKS-DKE                                                   
      DELZ=ZET-ZE                                                       
      IF(DELZ.GT.0.) THEN                                               
         DKZ=DZ                                                         
CX40194 CALL SBOUTX (194)                                               
CY40194 CALL SBOUTY (194)                                               
         RETURN                                                         
      ENDIF                                                             
      DELZ=DELZ*DELZ                                                    
      DZES=ZE-ZS                                                        
      DKSKE=DKS-DKE                                                     
C                                                                       
C        O'BRIEN'S FORMULATION                                          
C                                                                       
      DKZ=DKE+DELZ/(DZES**2.)*(DKSKE+(ZET-ZS)*(DKZS+2.*DKSKE/DZES))     
      DKZ=MAX(DKZ,DZ)                                                   
CX40194 CALL SBOUTX (194)                                               
CY40194 CALL SBOUTY (194)                                               
C                                                                       
      RETURN                                                            
      END                                                               
                                                                        
                                                                        
                                                                        
                                                                   
