      PROGRAM INITSS7                                                                                                               
C     PROGRAM INITSS7 (ICTL,       SPPHIS,       GSINIT,       START,           I2                                                  
C    1                                                         OUTPUT,  )       I2                                                  
C    1          TAPE99=ICTL, TAPE1=SPPHIS, TAPE2=GSINIT, TAPE3=START,                                                               
C    2                                                   TAPE6=OUTPUT)                                                              
C     ----------------------------------------------------------------          I2                                                  
C                                                                               I2                                                  
C     JUL 03/03 - A.IRWIN,F.MAJAESS (REVISED FOR F90 AND LINUX PLATFORMS)       I2                                                  
C     OCT 19/01 - M.LAZARE. - FLOAT -> REAL                                     I2                                                  
C                           - ADD FLEXIBILITY FOR MOIST=4HSLQB OPTION.          I2                                                  
C                           - OPTIMAL TOPOGRAPHY PHIS FIELD READ IN AND         I2                                                  
C                             SAVED DIRECTLY, RATHER THAN USING FIELD           I2                                                  
C                             ON CONTROL FILE AND CONVERTING FROM GG->SP.       I2                                                  
C     NOV 06/95 - R.HARVEY PREVIOUS VERSION INITSS6.                                                                                
C                                                                               I2                                                  
CINITSS7 - CONVERTS SIGMA LEVEL GAUSSIAN GRID DATASET TO SPHERICAL              I1                                                  
C          HARMONICS (OPTIMAL TOPOGRAPHY PHIS FIELD SAVED DIRECTLY)     3  1    I1                                                  
C                                                                               I3                                                  
CAUTHOR  - M.LAZARE                                                             I3                                                  
C                                                                               I3                                                  
CPURPOSE - PERFORMS GLOBAL SPECTRAL ANALYSIS OF ILEV SIGMA LEVELS               I3                                                  
C          OF GLOBAL GAUSSIAN GRIDS FOR INPUT TO THE HYBRID G.C.M.              I3                                                  
C          WINDS ARE CONVERTED TO VORTICITY AND DIVERGENCE.                     I3                                                  
C          A GLOBALLY-AVERAGED SURFACE PRESSURE (AVGPS) IS CALCULATED BASED     I3                                                  
C          ON THE INPUT LNSP FIELD FROM THE PROGRAM INITGSC, AND IS PASSED TO   I3                                                  
C          THE START FILE. THE MODEL SUBROUTINE INGCM5 READS THIS VALUE WHICH   I3                                                  
C          IS SUBSEQUENTLY USED TO EXPLICITY CORRECT FOR ANY TENDENCY FOR NON-  I3                                                  
C          CONSERVATION OF MASS DUE TO THE CHOICE OF LNSP AS A MODEL VARIABLE.  I3                                                  
C          NOTE: OPTIMAL TOPOGRAPHY PHIS FIELD READ IN AND SAVED DIRECTLY,      I3                                                  
C                RATHER THAN USING FIELD ON CONTROL FILE AND CONVERTING         I3                                                  
C                FROM GG->SP.                                                   I3                                                  
C                                                                               I3                                                  
CINPUT FILES...                                                                 I3                                                  
C                                                                               I3                                                  
C      ICTL   = INITIALIZATION CONTROL DATASET (SEE ICNTRL6)                    I3                                                  
C      SPPHIS = INITIALIZATION OPTIMAL SPECTRAL TOPOGRAPHY DATASET              I3                                                  
C      GSINIT = SIGMA/HYBRID LEVEL GAUSSIAN GRIDS CONTAINING THE FIELDS:        I3                                                  
C               GZS,LNSP,T(ILEV),((U,V)(ILEV)),ES(ILEV)                         I3                                                  
C                                                                               I3                                                  
COUTPUT FILE...                                                                 I3                                                  
C                                                                               I3                                                  
C      START  = SIGMA/HYBRID LEVEL SPECTRAL FIELDS OF...                        I3                                                  
C                                                                               I3                                                  
C                NAME   VARIABLE           UNITS     LEVELS                     I3                                                  
C                                                                               I3                                                  
C                LNSP   LN(SF.PRES.)       PA           1  SFC                  I3                                                  
C                TEMP   TEMPERATURE        DEG K     ILEV  SH                   I3                                                  
C                VORT   VORTICITY          1./SEC    ILEV  SG                   I3                                                  
C                 DIV   DIVERGENCE         1./SEC    ILEV  SG                   I3                                                  
C                  ES   MOISTURE VARIABLE            ILEV  SH                   I3                                                  
C                                                                               I3                                                  
C                THIS DATASET IS HEADED BY TWO SHORT RECORDS OF                 I3                                                  
C                MODEL CONTROL INFORMATION...                                   I3                                                  
C                NOTE THAT THESE SET CERTAIN RESOLUTION PARAMETERS              I3                                                  
C                WHICH ARE USED BY THE GCM WHEN IT STARTS UP.                   I3                                                  
C                                                                               I3                                                  
C                1. LABL,KSTART,ILEV,(SG(L),L=1,ILEV),(SH(L),L=1,ILEV),         I3                                                  
C                   LAY,ICOORD,PLID,MOIST                                       I3                                                  
C                2. LABL,LRLMT,ILGM,ILATM,IDAY,GMT                              I3                                                  
C                                                                               I3                                                  
C                LABL = 4 CHAR LABEL WORD.                                      I3                                                  
C                KSTART = INITIAL TIMESTEP NUMBER (SET TO 0).                   I3                                                  
C                LRLMT = SPECTRAL RESOLUTION (ONE WORD CONTAINING               I3                                                  
C                        LR, LM, AND KTR).                                      I3                                                  
C                                                                               I3                                                  
C-----------------------------------------------------------------------------                                                      
C                                                                                                                                   
      IMPLICIT REAL (A-H,O-Z),                                                                                                      
     +INTEGER (I-N)                                                                                                                 
      LOGICAL OK                                                                                                                    
      REAL*8 SL(96),CL(96),WL(96),WOSSL(96),RAD(96)                                                                                 
      REAL*8 SL2(96),CL2(96),WL2(96),WOSSL2(96),RAD2(96)                                                                            
      REAL*8 ALP(2210),DALP(2210),EPSI(2210)                                                                                        
      REAL SG(100),SH(100),TRIGS1(194),TRIGS2(194)                                                                                  
      REAL WRK1(12416),WRK2(19600)                                                                                                  
      INTEGER LSR(2,66),IFAX1(10),IFAX2(10)                                                                                         
                                                                                                                                    
C     * GG,GGX ARE WORK FIELDS FOR GAUSSIAN GRIDS (ILG1,ILAT).                                                                      
                                                                                                                                    
      COMPLEX Q,D                                                                                                                   
      COMMON /BLANCK/ Q(2145),D(2145)                                                                                               
      COMMON /BLANCK/ GG (18528),GGX (18528),WRKL(728)                                                                              
      COMMON /SCM   / WRKS(546,2)                                                                                                   
      COMMON /ICOM  / IBUF(8),IDAT(18528)                                                                                           
                                                                                                                                    
      DATA MAXX/18528/, MAXL/100/                                                                                                   
      DATA NF0,NF1,NF2,NPACK/ 1,2,3,2/                                                                                              
C-----------------------------------------------------------------------                                                            
      NFIL=5                                                                                                                        
      CALL JCLPNT (NFIL,99,1,2,3,6)                                                                                                 
                                                                                                                                    
C     * GET PARAMETERS FROM CONTROL FILE.                                                                                           
                                                                                                                                    
      REWIND 99                                                                                                                     
      READ(99,END=903) LABL,ILEV,                                                                                                   
     1                 (SG(L),L=1,ILEV),                                                                                            
     2                 (SH(L),L=1,ILEV),                                                                                            
     3                 LAY,ICOORD,PTOIT,MOIST                                                                                       
      IF((ILEV.LT.1).OR.(ILEV.GT.MAXL)) CALL       XIT('INITSS7',-1)                                                                
      READ(99,END=904) LABL,ILG,ILAT,ILGM,ILATM,LRLMT,IDAY,GMT                                                                      
      WRITE(6,6015)    LRLMT                                                                                                        
      WRITE(6,6017)    ILG,ILAT,ILGM,ILATM                                                                                          
      WRITE(6,6100)    LAY,ICOORD,PTOIT,MOIST                                                                                       
                                                                                                                                    
C     * WRITE CONTROL RECORDS ONTO START FILE.                                                                                      
                                                                                                                                    
      KSTART=0                                                                                                                      
      REWIND NF2                                                                                                                    
      CALL SETLAB  (IBUF,NC4TO8("DATA"),KSTART,NC4TO8("DATA"),1,                                                                    
     +                                           5+2*ILEV,1,0,0)                                                                    
      CALL FBUFOUT (NF2,IBUF,-8,K)                                                                                                  
      WRITE(NF2)   REAL(LABL),REAL(KSTART),REAL(ILEV),                                                                              
     1             (SG(L),L=1,ILEV),                                                                                                
     2             (SH(L),L=1,ILEV),                                                                                                
     3             REAL(LAY),PTOIT                                                                                                  
      CALL SETLAB  (IBUF,NC4TO8("DATA"),KSTART,NC4TO8("DATA"),1,6,1,0,0)                                                            
      CALL FBUFOUT (NF2,IBUF,-8,K)                                                                                                  
      WRITE(NF2)   REAL(LABL),REAL(LRLMT),REAL(ILGM),                                                                               
     1             REAL(ILATM),REAL(IDAY),GMT                                                                                       
                                                                                                                                    
C     * INITIALIZE CONSTANTS.                                                                                                       
                                                                                                                                    
      ILATH=ILAT/2                                                                                                                  
      ILG1 =ILG+1                                                                                                                   
      CALL DIMGT  (LSR,LA,LR,LM,KTR,LRLMT)                                                                                          
      CALL EPSCAL (EPSI,LSR,LM)                                                                                                     
      CALL GAUSSG (ILATH,SL,WL,CL,RAD,WOSSL)                                                                                        
      CALL  TRIGL (ILATH,SL,WL,CL,RAD,WOSSL)                                                                                        
C-----------------------------------------------------------------------                                                            
C     * LOG OF SURFACE PRESSURE (MILLIBARS).                                                                                        
C     * IN ADDITION TO PERFORMING SPECTRAL TRANSFORM, CALCULATE GLOBALLY-                                                           
C     * AVERAGED SURFACE PRESSURE AND SAVE ON START FILE.                                                                           
C                                                                                                                                   
      CALL GETFLD2(-NF1,GG ,NC4TO8("GRID"),0,NC4TO8("LNSP"),1,                                                                      
     +                                           IBUF,MAXX,OK)                                                                      
      IF(.NOT.OK) CALL                             XIT('INITSS7',-2)                                                                
      CALL PRTLAB (IBUF)                                                                                                            
      NPACK=MIN(NPACK,IBUF(8))                                                                                                      
      NWDS=IBUF(5)*IBUF(6)                                                                                                          
      DO 150 I=1,NWDS                                                                                                               
        GGX(I)=EXP(GG(I))                                                                                                           
  150 CONTINUE                                                                                                                      
      AVGPS=0.E0                                                                                                                    
      DO 190 J=1,ILAT                                                                                                               
        N = ILG1 * J                                                                                                                
        GGX(N) = 0.E0                                                                                                               
        DO 180 I=1,ILG                                                                                                              
          IJ = (J - 1) * ILG1 + I                                                                                                   
          GGX(N) = GGX(N) + GGX(IJ) * WL(J) * 0.5E0                                                                                 
  180   CONTINUE                                                                                                                    
        AVGPS = AVGPS + GGX(N) / ILG                                                                                                
  190 CONTINUE                                                                                                                      
      AVGPS=AVGPS*100.E0                                                                                                            
      WRITE(6,6020) (IBUF(N),N=1,4),AVGPS                                                                                           
      CALL SETLAB (IBUF,NC4TO8("DATA"),KSTART,NC4TO8("DATA"),1,2,1,0,0)                                                             
      CALL FBUFOUT (NF2,IBUF,-8,K)                                                                                                  
      WRITE(NF2) REAL(LABL),AVGPS                                                                                                   
      CALL GGAST2(Q,LSR,LM,LA, GG,ILG1,ILAT,1,SL,WL,                                                                                
     1                       ALP,EPSI,WRKS,WRKL)                                                                                    
      CALL SETLAB(IBUF,NC4TO8("SPEC"),0,NC4TO8("LNSP"),1,                                                                           
     +                                  LA,1,LRLMT,NPACK)                                                                           
      CALL PUTFLD2(NF2,Q,IBUF,MAXX)                                                                                                 
      WRITE(6,6026) IBUF                                                                                                            
C                                                                                                                                   
C     * MOUNTAINS (M/SEC)**2. (FROM OPTIMAL TOPOGRAPHY FILE).                                                                       
C                                                                                                                                   
      CALL GETFLD2(-NF0,Q,-1,-1,-1,-1,IBUF,MAXX,OK)                                                                                 
      IF(.NOT.OK) CALL                             XIT('INITSS7',-3)                                                                
      CALL PRTLAB (IBUF)                                                                                                            
      CALL SETLAB(IBUF,NC4TO8("SPEC"),0,NC4TO8("PHIS"),1,                                                                           
     +                                  LA,1,LRLMT,NPACK)                                                                           
      CALL PUTFLD2(NF2,Q,IBUF,MAXX)                                                                                                 
      WRITE(6,6026) IBUF                                                                                                            
                                                                                                                                    
C     * TEMPERATURE (DEG K).                                                                                                        
                                                                                                                                    
      REWIND NF1                                                                                                                    
      DO 250 L=1,ILEV                                                                                                               
        CALL GETFLD2 (NF1,GG ,NC4TO8("GRID"),0,NC4TO8("TEMP"),-1,                                                                   
     +                                              IBUF,MAXX,OK)                                                                   
        CALL PRTLAB (IBUF)                                                                                                          
        CALL GGAST2  (Q,LSR,LM,LA, GG,ILG1,ILAT,1,SL,WL,                                                                            
     1                ALP,EPSI,WRKS,WRKL)                                                                                           
        CALL SETLAB  (IBUF,NC4TO8("SPEC"),0,NC4TO8("TEMP"),-1,                                                                      
     +                                       LA,1,LRLMT,NPACK)                                                                      
        CALL PUTFLD2 (NF2,Q,IBUF,MAXX)                                                                                              
        WRITE(6,6026) IBUF                                                                                                          
  250 CONTINUE                                                                                                                      
                                                                                                                                    
C     * WIND COMPONENTS (U,V)*COS(LAT)/(EARTH RADIUS).                                                                              
C     * CONVERT TO VORTICITY AND DIVERGENCE (1./SEC).                                                                               
                                                                                                                                    
      REWIND NF1                                                                                                                    
      DO 350 L=1,ILEV                                                                                                               
        CALL GETFLD2 (NF1,GG ,NC4TO8("GRID"),0,NC4TO8("   U"),-1,                                                                   
     +                                              IBUF,MAXX,OK)                                                                   
        CALL PRTLAB (IBUF)                                                                                                          
        CALL GETFLD2 (NF1,GGX,NC4TO8("GRID"),0,NC4TO8("   V"),-1,                                                                   
     +                                              IBUF,MAXX,OK)                                                                   
        CALL PRTLAB (IBUF)                                                                                                          
        CALL GWAQD2  (Q,D,LSR,LM,GG,GGX,ILG1,ILAT,SL,WOSSL,                                                                         
     1                ALP,DALP,EPSI,WRKS,WRKL)                                                                                      
        CALL SETLAB  (IBUF,NC4TO8("SPEC"),0,NC4TO8("VORT"),-1,                                                                      
     +                                       LA,1,LRLMT,NPACK)                                                                      
        CALL PUTFLD2 (NF2,Q,IBUF,MAXX)                                                                                              
        WRITE(6,6026) IBUF                                                                                                          
        CALL SETLAB  (IBUF,NC4TO8("SPEC"),0,NC4TO8(" DIV"),-1,                                                                      
     +                                       LA,1,LRLMT,NPACK)                                                                      
        CALL PUTFLD2 (NF2,D,IBUF,MAXX)                                                                                              
        WRITE(6,6026) IBUF                                                                                                          
  350 CONTINUE                                                                                                                      
                                                                                                                                    
C     * MOISTURE VARIABLE.                                                                                                          
                                                                                                                                    
      REWIND NF1                                                                                                                    
                                                                                                                                    
      IF(MOIST.EQ.NC4TO8("SL3D") .OR. MOIST.EQ.NC4TO8("SLQB"))THEN                                                                  
                                                                                                                                    
        WRITE(6,6123) MOIST                                                                                                         
                                                                                                                                    
C     * MOISTURE FIELD MUST BE WRITTEN IN GRID FORM TO START FILE                                                                   
C     * LE SINUS DES LATITUDES GAUSSIENNES DOIVENT ETRE RECALCULE                                                                   
C     * (DANS SL2) POUR LA GRILLE ILATM, SL EST VALIDE POUR LA                                                                      
C     * GRILLE ILAT=128                                                                                                             
                                                                                                                                    
        CALL GAUSSG (ILATM/2,SL2,WL2,CL2,RAD2,WOSSL2)                                                                               
        CALL  TRIGL (ILATM/2,SL2,WL2,CL2,RAD2,WOSSL2)                                                                               
        CALL FTSETUP(TRIGS1,IFAX1,ILG)                                                                                              
        CALL FTSETUP(TRIGS2,IFAX2,ILGM)                                                                                             
                                                                                                                                    
        DO 440 L=1,ILEV                                                                                                             
           CALL GETFLD2 (NF1,GG ,NC4TO8("GRID"),0,NC4TO8("  ES"),-1,                                                                
     +                                                 IBUF,MAXX,OK)                                                                
           CALL PRTLAB (IBUF)                                                                                                       
           CALL GGAST (Q,LSR,LM,LA, GG,ILG1,ILAT,1,SL,WL,                                                                           
     1                   ALP,EPSI,WRK1,WRK2,TRIGS1,IFAX1,ILG1+1)                                                                    
           CALL FTSETUP(TRIGS2,IFAX2,ILGM)                                                                                          
           CALL STAGG (GG,ILGM+1,ILATM,1,SL2,Q,LSR,LM,LA,                                                                           
     1                   ALP,EPSI,WRK1,WRK2,TRIGS2,IFAX2,ILGM+2)                                                                    
                                                                                                                                    
C     * ELIMINATE NEGATIVE VALUES BEFORE SAVING THE MOISTURE FIELD                                                                  
                                                                                                                                    
           DO 400 NN=1,(ILGM+1)*ILATM                                                                                               
              GG(NN)=MAX(GG(NN),0.E0)                                                                                               
 400       CONTINUE                                                                                                                 
           CALL SETLAB  (IBUF,NC4TO8("GRID"),0,NC4TO8("  ES"),-1,                                                                   
     +                                      ILGM+1,ILATM,0,NPACK)                                                                   
           CALL PUTFLD2 (NF2,GG,IBUF,MAXX)                                                                                          
           WRITE(6,6026) IBUF                                                                                                       
 440    CONTINUE                                                                                                                    
                                                                                                                                    
      ELSE                                                                                                                          
                                                                                                                                    
        DO 450 L=1,ILEV                                                                                                             
          CALL GETFLD2 (NF1,GG ,NC4TO8("GRID"),0,NC4TO8("  ES"),-1,                                                                 
     +                                                IBUF,MAXX,OK)                                                                 
          CALL PRTLAB (IBUF)                                                                                                        
          CALL GGAST2  (Q,LSR,LM,LA, GG,ILG1,ILAT,1,SL,WL,                                                                          
     1                  ALP,EPSI,WRKS,WRKL)                                                                                         
          CALL SETLAB  (IBUF,NC4TO8("SPEC"),0,NC4TO8("  ES"),-1,                                                                    
     +                                         LA,1,LRLMT,NPACK)                                                                    
          CALL PUTFLD2 (NF2,Q,IBUF,MAXX)                                                                                            
          WRITE(6,6026) IBUF                                                                                                        
 450    CONTINUE                                                                                                                    
      ENDIF                                                                                                                         
                                                                                                                                    
      CALL                                         XIT('INITSS7',0)                                                                 
                                                                                                                                    
C     * E.O.F. ON FILE ICTL.                                                                                                        
                                                                                                                                    
  903 CALL                                         XIT('INITSS7',-4)                                                                
  904 CALL                                         XIT('INITSS7',-5)                                                                
C-----------------------------------------------------------------------                                                            
 5010 FORMAT (10X,5I5)                                                                                                              
 6015 FORMAT ('0 LRLMT =',I10)                                                                                                      
 6017 FORMAT ('0ANALYSIS GRID =',2I5,5X,'MODEL GRID =',2I5/)                                                                        
 6020 FORMAT(' FROM ',A4,2X,I10,2X,A4,2X,I10,' THE SURFACE MEAN IS ',                                                               
     1       E12.6)                                                                                                                 
 6026 FORMAT (' ',60X,A4,I10,2X,A4,I10,4I8)                                                                                         
 6100 FORMAT (' LAY=',I5,', COORD=',A4,', P.LID(PA)=',F10.3,                                                                        
     1        ', MOIST=',A4)                                                                                                        
 6123 FORMAT(' MOIST=',4A,' GRIDDED MOISTURE FIELD *NOT* CONVERTED',                                                                
     1       ' TO SPRECTRAL FORM')                                                                                                  
      END                                                                                                                           
