      PROGRAM SPDDDT                                                                                                                
C     PROGRAM SPDDDT (SPU,          SPV,          SPOMEG ,       SPDIV,         E2                                                  
C    1                SPVOR,        SPDDT,        INPUT,         OUTPUT,)       E2                                                  
C    2         TAPE11=SPU,   TAPE12=SPV,   TAPE13=SPOMEG, TAPE14=SPDIV,                                                             
C    3         TAPE15=SPVOR, TAPE16=SPDDT, TAPE5 =INPUT,  TAPE6 =OUTPUT)                                                            
C     ------------------------------------------------------------------        E2                                                  
C                                                                               E2                                                  
C     JUL 03/03 - A.IRWIN,F.MAJAESS (REVISED FOR F90 AND LINUX PLATFORMS)       E2                                                  
C     FEB 15/94 - F.MAJAESS (REVISE FOR TRUNCATIONS > 99)                                                                           
C     JAN 14/93 - E. CHAN  (DECODE LEVELS IN 8-WORD LABEL)                                                                          
C     JUL 13/92 - E. CHAN  (DIMENSION SELECTED VARIABLES AS REAL*8)                                                                 
C     JAN 29/92 - E. CHAN  (CONVERT HOLLERITH LITERALS TO ASCII)                                                                    
C     JAN 25/85 - B.DUGAS  (VECTORIZE)                                                                                              
C     APR   /80 - S. LAMBERT                                                                                                        
C                                                                               E2                                                  
CSPDDDT  - COMPUTES SPECTRAL TENDENCY OF DIVERGENCE                     5  1 C GE1                                                  
C                                                                               E3                                                  
CAUTHORS - S. LAMBERT, B. DUGAS                                                 E3                                                  
C                                                                               E3                                                  
CPURPOSE - COMPUTES THE SPHERICAL HARMONIC COEFFICIENTS OF THE DIVERGENCE       E3                                                  
C          TENDENCY FROM THE SPHERICAL HARMONIC COEFFICENTS OF BIG U,           E3                                                  
C          BIG V, OMEGA, DIVERGENCE AND VORTICITY. THE GEOPOTENTIAL             E3                                                  
C          LAPLACIAN TERM IS LEFT OUT OF THE RESULT.                            E3                                                  
C                                                                               E3                                                  
CINPUT FILES...                                                                 E3                                                  
C                                                                               E3                                                  
C      SPU    = GLOBAL SPECTRAL SETS OF MODEL U                                 E3                                                  
C      SPV    = GLOBAL SPECTRAL SETS OF MODEL V                                 E3                                                  
C      SPOMEG = GLOBAL SPECTRAL SETS OF VERTICAL MOTION (OMEGA)                 E3                                                  
C      SPDIV  = GLOBAL SPECTRAL SETS OF DIVERGENCE                              E3                                                  
C      SPVOR  = GLOBAL SPECTRAL SETS OF VORTICITY                               E3                                                  
C                                                                               E3                                                  
COUTPUT FILE...                                                                 E3                                                  
C                                                                               E3                                                  
C      SPDDT  = GLOBAL SPECTRAL SETS OF DIVERGENCE TENDENCY.                    E3                                                  
C                                                                                                                                   
CINPUT PARAMETERS...                                                                                                                
C                                                                               E5                                                  
C      NLAT  = NUMBER OF LATITUDES IN THE TRANSFORM GAUSSIAN GRID.              E5                                                  
C      ILONG = LENGTH OF A GAUSSIAN GRID ROW.                                   E5                                                  
C                                                                               E5                                                  
CEXAMPLE OF INPUT CARD...                                                       E5                                                  
C                                                                               E5                                                  
C*  SPDDDT   52   64                                                            E5                                                  
C-------------------------------------------------------------------------                                                          
C                                                                                                                                   
C     * THE WORKING FIELDS ARRAYS SC AND SL ARE                                                                                     
C     *       SC = SPECTRAL ACCUMULATION ARRAY (T30*15LEV*6VAR),                                                                    
C     *       SL = REAL (OR COMLEX) SLICE ARRAY (98GRID*15LEV*17VAR).                                                               
C                                                                                                                                   
      IMPLICIT REAL (A-H,O-Z),                                                                                                      
     +INTEGER (I-N)                                                                                                                 
      COMMON/LCM/SC,SL,ALP,DALP,EPSI                                                                                                
      COMPLEX SC(1326000),SL(164900)                                                                                                
      REAL*8    ALP(2275),DALP(2275),EPSI(2275)                                                                                     
      DIMENSION TRIGS(194),IFAX(10),LEV(100)                                                                                        
      REAL*8    S(96),WEIGHT(96),SIA(96),RAD(96),WOCS(96)                                                                           
      DIMENSION LSR(2,66),LRW(2,66)                                                                                                 
      DIMENSION PR(100),WRKS(12416)                                                                                                 
                                                                                                                                    
      COMMON/BUFCOM/IBUF(8),IDAT(4420)                                                                                              
      LOGICAL OK                                                                                                                    
      DATA MAXX,MAXLG,MAXSP / 4420,194,1326000 /                                                                                    
      DATA MAXL,MAXLT,MAXAM/ 100,96,2210 /                                                                                          
C-----------------------------------------------------------------------                                                            
      NFF=8                                                                                                                         
      CALL JCLPNT(NFF,11,12,13,14,15,16,5,6)                                                                                        
      NRECS=0                                                                                                                       
      DO 10 N=11,16                                                                                                                 
         REWIND N                                                                                                                   
   10 CONTINUE                                                                                                                      
                                                                                                                                    
C     * DETERMINE NUMBER OF LEVELS                                                                                                  
                                                                                                                                    
      CALL FILEV(LEV,NLEV,IBUF,11)                                                                                                  
      IF((NLEV.LT.1).OR.(NLEV.GT.MAXL)) CALL       XIT('SPDDDT',-1)                                                                 
      NLEV1=NLEV-1                                                                                                                  
      REWIND 11                                                                                                                     
      LRLMT=IBUF(7)                                                                                                                 
                                                                                                                                    
C     * READ SIZE OF TRANSFORM GRID                                                                                                 
                                                                                                                                    
      READ(5,5000,END=900) NLAT,ILONG                                           E4                                                  
      IF (ILONG.GT.MAXLG-2.OR.NLAT.GT.MAXLT)   THEN                                                                                 
          WRITE(6,6040) NLAT,ILONG, MAXLT, MAXLG-2                                                                                  
          CALL                                     XIT('SPDDDT',-2)                                                                 
      ELSE                                                                                                                          
          MAXLG=ILONG+2                                                                                                             
          ILH=MAXLG/2                                                                                                               
      ENDIF                                                                                                                         
      ILATH=NLAT/2                                                                                                                  
      CALL LVDCODE(PR,LEV,NLEV)                                                                                                     
      DO 20 L=1,NLEV                                                                                                                
         PR(L)=100.E0*PR(L)                                                                                                         
   20 CONTINUE                                                                                                                      
                                                                                                                                    
      IF(LRLMT.LT.100) CALL FXLRLMT (LRLMT,IBUF(5),IBUF(6),0)                                                                       
      CALL DIMGT(LRW,LAW,LW,LM,KTR,LRLMT)                                                                                           
      DO 25 I=LAW+1,MAXAM                                                                                                           
         ALP(I) =0.E0                                                                                                               
         DALP(I)=0.E0                                                                                                               
   25 CONTINUE                                                                                                                      
      CALL GAUSSG(ILATH,S,WEIGHT,SIA,RAD,WOCS)                                                                                      
      CALL TRIGL (ILATH,S,WEIGHT,SIA,RAD,WOCS)                                                                                      
      CALL EPSCAL(EPSI,LRW,LM)                                                                                                      
      CALL FTSETUP(TRIGS,IFAX,ILONG)                                                                                                
                                                                                                                                    
      LMP1=LM+1                                                                                                                     
      DO 30 M=2,LMP1                                                                                                                
         LSR(1,M)=LRW(1,M)-M+1                                                                                                      
         LSR(2,M)=LRW(2,M)                                                                                                          
   30 CONTINUE                                                                                                                      
      LSR(1,1)=1                                                                                                                    
      LSR(2,1)=1                                                                                                                    
      LA=LAW-LM                                                                                                                     
                                                                                                                                    
C     * GET STARTING POSITIONS OF FIELDS.                                                                                           
                                                                                                                                    
      ISU=1                                                                                                                         
      ISV=NLEV*LAW+ISU                                                                                                              
      ISW=NLEV*LAW+ISV                                                                                                              
      ISD=NLEV*LA +ISW                                                                                                              
      ISP=NLEV*LA +ISD                                                                                                              
      ISA=NLEV*LA +ISP                                                                                                              
      IF (ISA+LA*NLEV.GT.MAXSP)  CALL              XIT('SPDDDT',-3)                                                                 
                                                                                                                                    
      IU =1                                                                                                                         
      IV =NLEV*ILH+IU                                                                                                               
      IW =NLEV*ILH+IV                                                                                                               
      ID =NLEV*ILH+IW                                                                                                               
      IP =NLEV*ILH+ID                                                                                                               
      IUN=NLEV*ILH+IP                                                                                                               
      IVN=NLEV*ILH+IUN                                                                                                              
      IWN=NLEV*ILH+IVN                                                                                                              
      IDN=NLEV*ILH+IWN                                                                                                              
      IUL=NLEV*ILH+IDN                                                                                                              
      IVL=NLEV*ILH+IUL                                                                                                              
      IWL=NLEV*ILH+IVL                                                                                                              
      IDL=NLEV*ILH+IWL                                                                                                              
      IUP=NLEV*ILH+IDL                                                                                                              
      IVP=NLEV*ILH+IUP                                                                                                              
      IDP=NLEV*ILH+IVP                                                                                                              
      IA =NLEV*ILH+IDP                                                                                                              
                                                                                                                                    
C     * GET ANOTHER SLAB OF SPECTRAL DATA.                                                                                          
                                                                                                                                    
   40 DO 50 I=ISA,ISA+NLEV*LA-1                                                                                                     
         SC(I)=CMPLX(0.E0,0.E0)                                                                                                     
   50 CONTINUE                                                                                                                      
                                                                                                                                    
C     * READ INPUT FILES                                                                                                            
                                                                                                                                    
      DO 100 L=0,NLEV1                                                                                                              
                                                                                                                                    
         CALL GETFLD2(11,SC(ISU+L*LAW),NC4TO8("SPEC"),-1,                                                                           
     +                    NC4TO8("   U"),-1,IBUF,MAXX,OK)                                                                           
         IF(.NOT.OK)THEN                                                                                                            
           IF(NRECS.EQ.0) CALL                     XIT('SPDDDT',-4)                                                                 
           WRITE(6,6020) NRECS                                                                                                      
           CALL                                    XIT('SPDDDT',0)                                                                  
         ENDIF                                                                                                                      
         IF(NRECS.EQ.0) CALL PRTLAB (IBUF)                                                                                          
                                                                                                                                    
         CALL GETFLD2(12,SC(ISV+L*LAW),NC4TO8("SPEC"),-1,                                                                           
     +                    NC4TO8("   V"),-1,IBUF,MAXX,OK)                                                                           
         IF(.NOT.OK) CALL                          XIT('SPDDDT',-5)                                                                 
         IF(NRECS.EQ.0) CALL PRTLAB (IBUF)                                                                                          
                                                                                                                                    
         CALL GETFLD2(13,SC(ISW+ L*LA),NC4TO8("SPEC"),-1,                                                                           
     +                    NC4TO8("OMEG"),-1,IBUF,MAXX,OK)                                                                           
         IF(.NOT.OK) CALL                          XIT('SPDDDT',-6)                                                                 
         IF(NRECS.EQ.0) CALL PRTLAB (IBUF)                                                                                          
                                                                                                                                    
         CALL GETFLD2(14,SC(ISD+ L*LA),NC4TO8("SPEC"),-1,                                                                           
     +                    NC4TO8(" DIV"),-1,IBUF,MAXX,OK)                                                                           
         IF(.NOT.OK) CALL                          XIT('SPDDDT',-7)                                                                 
         IF(NRECS.EQ.0) CALL PRTLAB (IBUF)                                                                                          
                                                                                                                                    
         CALL GETFLD2(15,SC(ISP+ L*LA),NC4TO8("SPEC"),-1,                                                                           
     +                    NC4TO8("VORT"),-1,IBUF,MAXX,OK)                                                                           
         IF(.NOT.OK) CALL                          XIT('SPDDDT',-8)                                                                 
         IF(NRECS.EQ.0) CALL PRTLAB (IBUF)                                                                                          
                                                                                                                                    
  100 CONTINUE                                                                                                                      
                                                                                                                                    
      CALL DDDT(  SC(ISU),  SC(ISV),  SC(ISW),  SC(ISD),  SC(ISP),                                                                  
     1            SC(ISA),                                                                                                          
     2          SL(   IU),SL(   IV),SL(   IW),SL(   ID),SL(   IP),                                                                  
     3          SL(  IUN),SL(  IVN),SL(  IWN),SL(  IDN),SL(  IUL),                                                                  
     4          SL(  IVL),SL(  IWL),SL(  IDL),SL(  IUP),SL(  IVP),                                                                  
     6          SL(  IDP),SL(   IA),SL(   IU),SL(   IV),SL(   IW),                                                                  
     7          SL(   ID),          SL(  IUN),SL(  IVN),SL(  IWN),                                                                  
     8          SL(  IDN),SL(  IUL),SL(  IVL),SL(  IWL),SL(  IDL),                                                                  
     9          SL(  IUP),SL(  IVP),SL(  IDP), PR,                                                                                  
     A          ALP, DALP, EPSI, LSR, LRW, S, WEIGHT, TRIGS, IFAX,                                                                  
     B          ILONG, NLAT, NLEV, ILH, MAXLG, LA, LAW, LM, WRKS)                                                                   
                                                                                                                                    
      IBUF(3)=NC4TO8("DDDT")                                                                                                        
                                                                                                                                    
      DO 750 L=0,NLEV1                                                                                                              
         IBUF(4)=LEV(L+1)                                                                                                           
         CALL PUTFLD2(16,SC(ISA+ L*LA),IBUF,MAXX)                                                                                   
         IF(NRECS.EQ.0) CALL PRTLAB (IBUF)                                                                                          
750   CONTINUE                                                                                                                      
      NRECS=NRECS+1                                                                                                                 
      GOTO 40                                                                                                                       
                                                                                                                                    
C     * END OF INPUT ON UNIT 5.                                                                                                     
                                                                                                                                    
900   CALL                                         XIT('SPDDDT',-9)                                                                 
C-----------------------------------------------------------------------                                                            
 5000 FORMAT(10X,2I5)                                                           E4                                                  
 6020 FORMAT('0SPDDDT PRODUCED',I6,' SETS OF COEFS')                                                                                
 6040 FORMAT(' NLAT,ILONG = ',2I5,' , MAXIMUM ACCEPTABLE ARE ',2I5)                                                                 
      END                                                                                                                           
