      PROGRAM SPDTDT                                                                                                                
C     PROGRAM SPDTDT (SPU,        SPV,           SPOMEG,        SPTEMP,         E2                                                  
C    1                            SPDTDT,        INPUT,         OUTPUT, )       E2                                                  
C    2         TAPE11=SPU, TAPE12=SPV,    TAPE13=SPOMEG, TAPE14=SPTEMP,                                                             
C    3                     TAPE15=SPDTDT, TAPE5 =INPUT,  TAPE6 =OUTPUT)                                                             
C     -----------------------------------------------------------------         E2                                                  
C                                                                               E2                                                  
C     MAR 17/04 - F.KHARIN (CHECK FOR VALID DIMENSION FACTORS)                  E2                                                  
C     JUL 03/03 - A.IRWIN,F.MAJAESS (REVISED FOR F90 AND LINUX PLATFORMS)                                                           
C     FEB 15/94 - F.MAJAESS (REVISE FOR TRUNCATIONS > 99)                                                                           
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 24/85 - B.DUGAS  (INCREASE MAX DIMENSION TO T40)                                                                          
C     APR   /80 - S. LAMBERT                                                                                                        
C                                                                               E2                                                  
CSPDTDT  - COMPUTES SPECTRAL TENDENCY OF TEMPERATURE                    4  1 C GE1                                                  
C                                                                               E3                                                  
CAUTHOR - S.LAMBERT                                                             E3                                                  
C                                                                               E3                                                  
CPURPOSE - COMPUTES THE SPHERICAL HARMONIC COEFFICIENTS OF THE TEMPERATURE      E3                                                  
C          TENDENCY FROM THE SPHERICAL HARMONIC COEFFICENTS OF BIG U, BIG V,    E3                                                  
C          OMEGA AND TEMPERATURE USING THE MODEL THERMODYNAMIC EQUATION.        E3                                                  
C                                                                               E3                                                  
CINPUT FILES...                                                                 E3                                                  
C                                                                               E3                                                  
C      SPU    = GLOBAL SPECTRAL MODEL U                                         E3                                                  
C      SPV    = GLOBAL SPECTRAL MODEL V                                         E3                                                  
C      SPOMEG = GLOBAL SPECTRAL VERTICAL MOTION (OMEGA)                         E3                                                  
C      SPTEMP = GLOBAL SPECTRAL TEMPERATURES                                    E3                                                  
C                                                                               E3                                                  
COUTPUT FILE...                                                                 E3                                                  
C                                                                               E3                                                  
C      SPDTDT = GLOBAL SPECTRAL TEMPERATURE TENDENCIES                          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*  SPDTDT   52   64                                                            E5                                                  
C----------------------------------------------------------------------------                                                       
C                                                                                                                                   
      IMPLICIT REAL (A-H,O-Z),                                                                                                      
     +INTEGER (I-N)                                                                                                                 
      COMMON/LCM/SCU,SCV,SCW,SCX,SCANS,UF,VF,WF,XF,XFLNG,XFLAT,XFP,ANSF                                                             
      COMMON/LCM/ U,V,W,XLAT,XLNG,XP,ANS,ALP,DALP,EPSI,X                                                                            
      COMPLEX SCU(2210,100),SCV(2210,100),SCW(2145,100)                                                                             
      COMPLEX SCX(2145,100),SCANS(2145,100),UF(66,100)                                                                              
      COMPLEX VF(66,100),WF(66,100),XF(66,100)                                                                                      
      COMPLEX XFLNG(66,100),XFLAT(66,100),XFP(66,100)                                                                               
      COMPLEX ANSF(66,100),F(2145)                                                                                                  
      DIMENSION U(194,100),V(194,100),W(194,100)                                                                                    
      DIMENSION XLAT(194,100),XLNG(194,100),XP(194,100)                                                                             
      DIMENSION ANS(194,100),LEV(100),PR(100),LSR(2,66)                                                                             
      REAL*8    ALP(2275),DALP(2275),EPSI(2275)                                                                                     
      REAL*8    S(96),WEIGHT(96),SIA(96),RAD(96),WOCS(96)                                                                           
      DIMENSION LRW(2,66),LAX(2,66),X(194,100),WRKS(1092)                                                                           
      INTEGER IFAX(10)                                                                                                              
      REAL TRIGS(194)                                                                                                               
C                                                                                                                                   
      COMMON/BUFCOM/IBUF(8),IDAT(4290)                                                                                              
      LOGICAL OK                                                                                                                    
      DATA MAXX/4290/, MAXL/100/,  MAXLG/194/, MAXR/2145/                                                                           
      DATA MAXLT/96/, MAXIJ/194/, MAXM1/66/                                                                                         
C-----------------------------------------------------------------------                                                            
      NFF=7                                                                                                                         
      CALL JCLPNT(NFF,11,12,13,14,15,5,6)                                                                                           
      NRECS=0                                                                                                                       
      DO 70 N=11,15                                                                                                                 
70    REWIND N                                                                                                                      
C                                                                                                                                   
C     * DETERMINE NUMBER OF LEVELS                                                                                                  
C                                                                                                                                   
      CALL FILEV(LEV,NLEV,IBUF,11)                                                                                                  
      IF((NLEV.LT.1).OR.(NLEV.GT.MAXL)) CALL       XIT('SPDTDT',-1)                                                                 
      REWIND 11                                                                                                                     
      NLEV1=NLEV-1                                                                                                                  
      LRLMT=IBUF(7)                                                                                                                 
C                                                                                                                                   
C     * READ SIZE OF TRANSFORM GRID                                                                                                 
C                                                                                                                                   
      READ(5,5000,END=910) NLAT,ILONG                                           E4                                                  
      IF((NLAT.GT.MAXLT).OR.(ILONG.GT.(MAXLG-2)))                                                                                   
     1  CALL                                       XIT('SPDTDT',-2)                                                                 
C                                                                                                                                   
C     * CHECK DIMENSION FACTORS                                                                                                     
C                                                                                                                                   
      CALL FTSETUP(TRIGS,IFAX,NLG)                                                                                                  
      NFAX=IFAX(1)                                                                                                                  
      NFAX2=0                                                                                                                       
      NFAX3=0                                                                                                                       
      NFAX5=0                                                                                                                       
      DO I=1,NFAX                                                                                                                   
        IF(IFAX(I+1).EQ.2)THEN                                                                                                      
          NFAX2=NFAX2+1                                                                                                             
        ELSEIF(IFAX(I+1).EQ.3)THEN                                                                                                  
          NFAX3=NFAX3+1                                                                                                             
        ELSEIF(IFAX(I+1).EQ.4)THEN                                                                                                  
          NFAX2=NFAX2+2                                                                                                             
        ELSEIF(IFAX(I+1).EQ.5)THEN                                                                                                  
          NFAX5=NFAX5+1                                                                                                             
        ELSEIF(IFAX(I+1).EQ.6)THEN                                                                                                  
          NFAX2=NFAX2+1                                                                                                             
          NFAX3=NFAX3+1                                                                                                             
        ELSEIF(IFAX(I+1).EQ.8)THEN                                                                                                  
          NFAX2=NFAX2+3                                                                                                             
        ENDIF                                                                                                                       
      ENDDO                                                                                                                         
C                                                                                                                                   
C     * FFGFW2 WORKS ONLY FOR NLG=2**N OR NLG=3*2**N                                                                                
C                                                                                                                                   
      IF(NFAX5.GT.0.OR.NFAX3.GT.1)CALL             XIT('SPDTDT',-20)                                                                
                                                                                                                                    
      ILATH=NLAT/2                                                                                                                  
      CALL LVDCODE(PR,LEV,NLEV)                                                                                                     
      DO 25 L=1,NLEV                                                                                                                
25    PR(L)=100.*PR(L)                                                                                                              
      CALL DIMGT(LRW,LAW,LW,LM,KTR,LRLMT)                                                                                           
      IR=LM-1                                                                                                                       
      CALL GAUSSG(ILATH,S,WEIGHT,SIA,RAD,WOCS)                                                                                      
      CALL TRIGL (ILATH,S,WEIGHT,SIA,RAD,WOCS)                                                                                      
      CALL EPSCAL(EPSI,LRW,LM)                                                                                                      
      LMP1=LM+1                                                                                                                     
      DO 30 M=2,LMP1                                                                                                                
      LSR(1,M)=LRW(1,M)-M+1                                                                                                         
30    LSR(2,M)=LRW(2,M)                                                                                                             
      LSR(1,1)=1                                                                                                                    
      LSR(2,1)=1                                                                                                                    
      LA=LAW-LM                                                                                                                     
150   DO 50 I=1,MAXR                                                                                                                
      DO 50 J=1,MAXL                                                                                                                
50    SCANS(I,J)=CMPLX(0.,0.)                                                                                                       
C                                                                                                                                   
C     * READ INPUT FILES                                                                                                            
C                                                                                                                                   
      DO 100 L=1,NLEV                                                                                                               
      CALL GETFLD2(11,SCU(1,L),NC4TO8("SPEC"),-1,NC4TO8("   U"),-1,                                                                 
     +                                                IBUF,MAXX,OK)                                                                 
      IF(.NOT.OK)THEN                                                                                                               
        IF(NRECS.EQ.0) CALL                        XIT('SPDTDT',-3)                                                                 
        WRITE(6,6020) NRECS                                                                                                         
        CALL                                       XIT('SPDTDT',0)                                                                  
      ENDIF                                                                                                                         
      IF(NRECS.EQ.0) CALL PRTLAB (IBUF)                                                                                             
      CALL GETFLD2(12,SCV(1,L),NC4TO8("SPEC"),-1,NC4TO8("   V"),-1,                                                                 
     +                                                IBUF,MAXX,OK)                                                                 
      IF(.NOT.OK) CALL                             XIT('SPDTDT',-4)                                                                 
      IF(NRECS.EQ.0) CALL PRTLAB (IBUF)                                                                                             
      CALL GETFLD2(13,SCW(1,L),NC4TO8("SPEC"),-1,NC4TO8("OMEG"),-1,                                                                 
     +                                                IBUF,MAXX,OK)                                                                 
      IF(.NOT.OK) CALL                             XIT('SPDTDT',-5)                                                                 
      IF(NRECS.EQ.0) CALL PRTLAB (IBUF)                                                                                             
      CALL GETFLD2(14,SCX(1,L),NC4TO8("SPEC"),-1,NC4TO8("TEMP"),-1,                                                                 
     +                                                IBUF,MAXX,OK)                                                                 
      IF(.NOT.OK) CALL                             XIT('SPDTDT',-6)                                                                 
      IF(NRECS.EQ.0) CALL PRTLAB (IBUF)                                                                                             
100   CONTINUE                                                                                                                      
C                                                                                                                                   
C     * LOOP OVER TRANSFORM GRID LATITUDES                                                                                          
C                                                                                                                                   
      DO 600 IH=1,NLAT                                                                                                              
      CALL ALPST2(ALP,LRW,LM,S(IH),EPSI)                                                                                            
      CALL ALPDY2(DALP,ALP,LRW,LM,EPSI)                                                                                             
C                                                                                                                                   
C     * COMPUTE FOURIER COEFFICIENTS                                                                                                
C                                                                                                                                   
      DO 510 L=1,NLEV                                                                                                               
      CALL STAF2(UF(1,L),SCU(1,L),LRW,LM,ALP)                                                                                       
      CALL STAF2(VF(1,L),SCV(1,L),LRW,LM,ALP)                                                                                       
      SCW(1,L)=CMPLX(0.,0.)                                                                                                         
      CALL STAF2(WF(1,L),SCW(1,L),LSR,LM,ALP)                                                                                       
      CALL STAF2(XF(1,L),SCX(1,L),LSR,LM,ALP)                                                                                       
      CALL STAF2(XFLNG(1,L),SCX(1,L),LSR,LM,DALP)                                                                                   
      DO 520 M1=1,LM                                                                                                                
      AM=FLOAT(M1-1)                                                                                                                
520   XFLAT(M1,L)=CMPLX(-AM* IMAG(XF(M1,L)),AM*REAL(XF(M1,L)))                                                                      
510   CONTINUE                                                                                                                      
      DO 530 K=2,NLEV1                                                                                                              
      DO 530 M=1,LM                                                                                                                 
530   XFP(M,K)=(XF(M,K+1)-XF(M,K-1))/(PR(K+1)-PR(K-1))                                                                              
      DO 535 M=1,LM                                                                                                                 
      XFP(M,1)=(XF(M,2)-XF(M,1))/(PR(2)-PR(1))                                                                                      
535   XFP(M,NLEV)=(XF(M,NLEV)-XF(M,NLEV1))/(PR(NLEV)-PR(NLEV1))                                                                     
C                                                                                                                                   
C     * COMPUTE GRID POINT VALUES                                                                                                   
C                                                                                                                                   
      CALL FFGFW2(U,MAXIJ,UF,MAXM1,IR,ILONG,WRKS,NLEV)                                                                              
      CALL FFGFW2(V,MAXIJ,VF,MAXM1,IR,ILONG,WRKS,NLEV)                                                                              
      CALL FFGFW2(W,MAXIJ,WF,MAXM1,IR,ILONG,WRKS,NLEV)                                                                              
      CALL FFGFW2(X,MAXIJ,XF,MAXM1,IR,ILONG,WRKS,NLEV)                                                                              
      CALL FFGFW2(XLAT,MAXIJ,XFLAT,MAXM1,IR,ILONG,WRKS,NLEV)                                                                        
      CALL FFGFW2(XLNG,MAXIJ,XFLNG,MAXM1,IR,ILONG,WRKS,NLEV)                                                                        
      CALL FFGFW2(XP,MAXIJ,XFP,MAXM1,IR,ILONG,WRKS,NLEV)                                                                            
      COSSQ=1.-S(IH)*S(IH)                                                                                                          
      DO 540 L=1,NLEV                                                                                                               
C                                                                                                                                   
C     * COMPUTE TENDENCY ON THE GRID                                                                                                
C                                                                                                                                   
      DO 540 I=1,ILONG                                                                                                              
      ANS(I,L)=-(U(I,L)*XLAT(I,L)+V(I,L)*XLNG(I,L))/COSSQ-W(I,L)*XP(I,L)                                                            
     1 +287.04*X(I,L)*W(I,L)/(1004.2*PR(L))                                                                                         
540   CONTINUE                                                                                                                      
C                                                                                                                                   
C     * COMPUTE FOURIER COEFFICIENTS                                                                                                
C                                                                                                                                   
      CALL FFWFG2(ANSF,MAXM1,ANS,MAXIJ,IR,ILONG,WRKS,NLEV)                                                                          
C                                                                                                                                   
C     * COMPUTE SPHERICAL HARMONIC COEFFICIENTS                                                                                     
C                                                                                                                                   
      DO 550 L=1,NLEV                                                                                                               
      CALL FAST2(SCANS(1,L),LSR,LM,ANSF(1,L),ALP,WEIGHT(IH))                                                                        
550   CONTINUE                                                                                                                      
600   CONTINUE                                                                                                                      
      IBUF(3)=NC4TO8("DTDT")                                                                                                        
      IBUF(5)=LA                                                                                                                    
      IBUF(6)=1                                                                                                                     
      DO 750 L=1,NLEV                                                                                                               
      IBUF(4)=LEV(L)                                                                                                                
      CALL PUTFLD2(15,SCANS(1,L),IBUF,MAXX)                                                                                         
      IF(NRECS.EQ.0) CALL PRTLAB (IBUF)                                                                                             
750   CONTINUE                                                                                                                      
      NRECS=NRECS+1                                                                                                                 
      GO TO 150                                                                                                                     
C                                                                                                                                   
C     * E.O.F. ON INPUT.                                                                                                            
C                                                                                                                                   
  910 CALL                                         XIT('SPDTDT',-7)                                                                 
C---------------------------------------------------------------------                                                              
 5000 FORMAT(10X,2I5)                                                           E4                                                  
 6020 FORMAT('0SPDTDT PRODUCED',I6,' SETS OF COEFS')                                                                                
      END                                                                                                                           
