      PROGRAM SPLDISS                                                                                                               
C     PROGRAM SPLDISS (IN,       OUT,       INPUT,       OUTPUT,        )       E2                                                  
C    1           TAPE1=IN, TAPE2=OUT, 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 29/92 - E. CHAN  (CONVERT HOLLERITH LITERALS TO ASCII)                                                                    
C     OCT   /86 - G.J.BOER (CORRECTED)                                                                                              
C     MAY 13/83 - R.LAPRISE.                                                                                                        
C     JUN 01/79 - TED SHEPHERD.                                                                                                     
C                                                                               E2                                                  
CSPLDISS - COMPUTES SPECTRAL LEITH DISSIPATION FUNCTION                 1  1 C GE1                                                  
C                                                                               E3                                                  
CAUTHOR  - T.SHEPHERD                                                           E3                                                  
C                                                                               E3                                                  
CPURPOSE - COMPUTES THE LEITH DISSIPATION FUNCTION L(M,N) FOR EACH FIELD        E3                                                  
C          IN A GLOBAL SPECTRAL FILE. THIS FUNCTION IS DEFINED AS:              E3                                                  
C                                                                               E3                                                  
C               L(M,N) = ETA3*F(N) FOR N>NZ                                     E3                                                  
C                                                                               E3                                                  
C          WHERE,                                                               E3                                                  
C                                                                               E3                                                  
C               F(N)   = 4*(N-NZ)/NSTAR                                         E3                                                  
C               NZ     = 0.55*NSTAR.                                            E3                                                  
C               ETA3   = THE CUBIC ROOT OF THE ENSTROPHY FLUX RATE,             E3                                                  
C          AND  NSTAR  = THE TRUNCATION WAVENUMBER.                             E3                                                  
C                                                                               E3                                                  
C          NOTE - OUTPUTED RESULTS ARE ON AS MANY LEVELS AND FOR AS MANY        E3                                                  
C                 STEPS AS THE INPUT FILE HAS.                                  E3                                                  
C                                                                               E3                                                  
C                                                                               E3                                                  
CINPUT FILE...                                                                  E3                                                  
C                                                                               E3                                                  
C      IN  = GLOBAL SPECTRAL FIELDS                                             E3                                                  
C                                                                               E3                                                  
COUTPUT FILE...                                                                 E3                                                  
C                                                                               E3                                                  
C      OUT = CORRESPONDING FILE OF LEITH DISSIPATION FOR EACH WAVENUMBER        E3                                                  
C                                                                                                                                   
CINPUT PARAMETERS...                                                                                                                
C                                                                               E5                                                  
C      NSTAR = THE TRUNCATION WAVENUMBER.                                       E5                                                  
C      ETA3  = THE CUBIC ROOT OF THE ENSTROPHY FLUX RATE,                       E5                                                  
C      ITEST = 0, THE NEGATIVE VALUES IN THE DISSIPATION FUNCTION ARE SET       E5                                                  
C                 TO ZERO.                                                      E5                                                  
C            <>0, (OTHERWISE) THE NEGATIVE VALUES ARE RETAINED.                 E5                                                  
C                                                                               E5                                                  
CEXAMPLE OF INPUT CARD...                                                       E5                                                  
C                                                                               E5                                                  
C* SPLDISS   15       1.0    0                                                  E5                                                  
C-----------------------------------------------------------------------------                                                      
C                                                                                                                                   
      IMPLICIT REAL (A-H,O-Z),                                                                                                      
     +INTEGER (I-N)                                                                                                                 
      LOGICAL OK                                                                                                                    
C                                                                                                                                   
      INTEGER LSR(2,66)                                                                                                             
      COMMON/BLANCK/G(4420)                                                                                                         
C                                                                                                                                   
      COMMON/ICOM/IBUF(8),IDAT(4420)                                                                                                
      DATA MAXX/4420/                                                                                                               
C-----------------------------------------------------------------------                                                            
      NFF=4                                                                                                                         
      CALL JCLPNT(NFF,1,2,5,6)                                                                                                      
      REWIND 1                                                                                                                      
      REWIND 2                                                                                                                      
C                                                                                                                                   
      READ(5,5010,END=902) NSTAR,ETA3,ITEST                                     E4                                                  
      NKNOT=INT(0.55E0*FLOAT(NSTAR)+0.5E0)                                                                                          
      WRITE(6,6010) NKNOT,NSTAR,ETA3                                                                                                
C                                                                                                                                   
C     * READ RECORDS OF INPUT FILE, TO GIVE FILE OUT THE SAME DIMENSION.                                                            
C                                                                                                                                   
      NR=0                                                                                                                          
100   CALL GETFLD2(1,G,NC4TO8("SPEC"),-1,0,-1,IBUF,MAXX,OK)                                                                         
      IF(.NOT.OK)THEN                                                                                                               
        IF(NR.EQ.0) CALL                           XIT('SPLDISS',-1)                                                                
        WRITE(6,6020) NR                                                                                                            
        CALL                                       XIT('SPLDISS',0)                                                                 
      ENDIF                                                                                                                         
C                                                                                                                                   
C     * IF NR=0, CHECK TO SEE WHETHER LABELS ARE OLD OR NEW.                                                                        
C                                                                                                                                   
      LRLMT=IBUF(7)                                                                                                                 
      IF(LRLMT.LT.100) CALL FXLRLMT (LRLMT,IBUF(5),IBUF(6),0)                                                                       
      CALL DIMGT(LSR,LA,LR,LM,KTR,LRLMT)                                                                                            
C                                                                                                                                   
C     * IF ITEST EQUAL TO ZERO, THE NEGATIVE VALUES IN THE DISSIPATION                                                              
C     * FUNCTION ARE SET TO ZERO.  IF ITEST NOT EQUAL TO ZERO, THE                                                                  
C     * NEGATIVE VALUES ARE RETAINED.                                                                                               
C                                                                                                                                   
      IF(ITEST.EQ.0)THEN                                                                                                            
        CALL LEITH(G,LSR,LM,LA,NKNOT,NSTAR,ETA3)                                                                                    
        IF(NR.EQ.0) WRITE(6,6040)                                                                                                   
      ELSE                                                                                                                          
        CALL ELEITH(G,LSR,LM,LA,NSTAR,ETA3)                                                                                         
        IF(NR.EQ.0) WRITE(6,6050)                                                                                                   
      ENDIF                                                                                                                         
C                                                                                                                                   
C     * SAVE ON FILE OUT.                                                                                                           
C                                                                                                                                   
150   IBUF(3)=NC4TO8("LDIS")                                                                                                        
      CALL PUTFLD2(2,G,IBUF,MAXX)                                                                                                   
      IF(NR.EQ.0) CALL PRTLAB (IBUF)                                                                                                
      NR=NR+1                                                                                                                       
      GO TO 100                                                                                                                     
C                                                                                                                                   
C     * E.O.F. ON INPUT.                                                                                                            
C                                                                                                                                   
  902 CALL                                         XIT('SPLDISS',-2)                                                                
C-----------------------------------------------------------------------                                                            
 5010 FORMAT(10X,I5,E10.0,I5)                                                   E4                                                  
 6010 FORMAT('0NKNOT,NSTAR,ETA3 =',I4,' ,',I4,' ,',1PE15.6)                                                                         
 6020 FORMAT('0SPLDISS PRODUCED',I6,' RECORDS')                                                                                     
 6040 FORMAT(2X,'INCOMPLETE LEITH FUNCTION USED',/)                                                                                 
 6050 FORMAT(2X,'  COMPLETE LEITH FUNCTION USED',/)                                                                                 
      END                                                                                                                           
