*COMDECK PARAM1                                                            PARAM1.1     
      PARAMETER(NN=42,MM=42,NHEM=1,MOCT=1,MG=128,JG=32,NWJ2=462,           PARAM1.2     
     : NCRAY=64,JGL=JG)                                                    PARAM1.3     
*COMDECK PARAM2                                                            PARAM2.1     
      PARAMETER(PI=3.14159265359,PI2=2.*PI,                                PARAM2.2     
     : NNP=NN+1,MGPP=MG+2,MJP=NWJ2+NWJ2,NWW=1+(MM-1)/MOCT,                 PARAM2.3     
     : IDA=(3*MG)/2+1,IDF=NCRAY*(MG+1),IDM=(NN+1)/2,                       PARAM2.4     
     : IDL=MGPP/2,IOUTL=14)                                                BUGSV.90    
      PARAMETER(IGA=NWJ2*NHEM,IGC=MGPP*NHEM,IGL=IDL*NHEM,IGM=IDM*NHEM,     PARAM2.6     
     : JGG=NHEM*JG)                                                        PARAM2.7     
*COMDECK GRIDP                                                             GRIDP.1     
      COMMON/GRIDP/ZG(IGC),UPSI(IGC),VPSI(IGC),UZG(IGC),                   GRIDP.2     
     : VZG(IGC),ETAVHT(IGC),                                               GRIDP.3     
     : UCHI(IGC,JGL),VCHI(IGC,JGL),DG(IGC,JGL),                            GRIDP.4     
     : GSG(IGC,JGL),GSX(IGC,JGL),GSY(IGC,JGL)                              GRIDP.5     
*COMDECK SPECTR                                                            SPECTR.1     
      COMMON/SPECTR/Z(IGA),ZT(IGA),ZMI(IGA),ZRES(IGA),ZROSS(IGA)           SPECTR.2     
      COMPLEX Z,ZT,ZMI,ZRES,ZROSS                                          SPECTR.3     
*COMDECK LEGAU                                                             LEGAU.1     
      COMMON/LEGAU/ALP(MJP,JGL),DALP(MJP,JGL),RLP(MJP,JGL),RDLP(MJP,JGL)   LEGAU.2     
     : ,SI(JG),AW(JG),CS(JG)                                               LEGAU.3     
     : ,WEIGHT,CSJ,RSCJ,SIT,JH,JL,JINC                                     LEGAU.4     
*COMDECK COMFFT                                                            COMFFT.1     
      COMMON/COMFFT/NTWG,NTGW,                                             COMFFT.2     
     : TRIG(IDA),WORK(IDF),IFAX(10)                                        COMFFT.3     
*COMDECK BLANK                                                             BLANK.1     
      COMMON/BLANK/WW,RADEA,GA,CV,EZ,PNU,PNU21,TDISS,NDEL,RESTIM,HGT,      BLANK.2     
     : RNTAPE,KOUNT,KTOTAL,KITS,DAY,TSPD,DELT,DELT2,                       BLANK.3     
     : AK(NNP),SQ(NNP),RSQ(NNP),ALAT(JG),NLEVD,NLEVZ,LFIXZN,LDIVZN,        BLANK.4     
     : NLAT,NLONG,KOUNTO,SGINC(IOUTL),LSPO(IOUTL),LUTF,LPRINT              BLANK.5     
     : ,LOLD,LCOR                                                          BUGSV.51    
      LOGICAL LFIXZN,LDIVZN,LSPO,LUTF,LPRINT                               BLANK.6     
     : ,LOLD,LCOR                                                          BUGSV.52    
*COMDECK INPB                                                              INPB.1     
      NAMELIST/INPB/RNTAPE,KITS,TSPD,TDISS,NDEL,RESTIM,SGINC,              INPB.2     
     : KTOTAL,NLEVZ,NLEVD,HGT,NLAT,NLONG,KOUNTO,LSPO,LUTF,LPRINT,          INPB.3     
     : LFIXZN,LDIVZN,LOLD,LCOR                                             BUGSV.53    
*COMDECK POLYNO                                                            POLYNO.1     
      COMMON/POLYNO/POLY(NWJ2,NHEM),CMPA(IGL)                              POLYNO.2     
      COMPLEX CMPA                                                         POLYNO.3     
*DECK VAROT                                                                VAROT.1     
      PROGRAM VAROT                                                        VAROT.2     
C                                                                          VAROT.3     
C     THE NEW READING BAROTROPIC MODEL, USING JAGGED TRIANGULAR            VAROT.4     
C        TRUNCATION AND WITH ALL SWITHCHES OPERATIONAL.                    VAROT.5     
C     IT HAS BEEN WRITTEN TO BE AS SIMILAR TO RSGUP AS POSSIBLE.           VAROT.6     
C     THE TRANSFORM ROUTINES HAVE BEEN TAKEN FROM THE FLUX PROGRAM,        VAROT.7     
C       THE ADIABATIC TIME STEP IS THE SAME AS THE BAROCLINIC MODEL,       VAROT.8     
C          THE DIABATIC ONE USES THE ZMI FIELDS FOR STABILITY.             VAROT.9     
C       OUTPUT IS TO FPLOT16 FORMAT FILES                                  VAROT.10    
C                                                                          BUGSV.37    
C      A NUMBER OF FILE CHANNELS ARE USED.                                 BUGSV.38    
C         FT05   INPUT CHANNEL                                             BUGSV.39    
C         FT06   OUTPUT                                                    BUGSV.40    
C         FT10   HISTORY RECORD CONTAINING VORTICITY AND DIVERGENCE        BUGSV.41    
C         FT24   FINAL RESTART RECORD                                      BUGSV.42    
C         FT25   WORK FILE FOR LEGENDRE COEFFICEINTS (ONLY IF JGL=1)       BUGSV.43    
C         FT26   WORK FILE FOR OROGRAPHY & DERIVATIVES (ONLY IF JGL=1)     BUGSV.44    
C         FT27   WORK FILE FOR DIVERGENCE ETC          (ONLY IF JGL=1)     BUGSV.45    
C         FT28   TEMPORARY CHANNEL FOR OUTPUT FIELDS                       BUGSV.46    
C         FT36   INPUT CHANNEL FOR SPECTRAL OROGRAPHY                      BUGSV.47    
C         FT37   INPUT CHANNEL FOR GRID POINT OROGRAPHY                    BUGSV.48    
C         FT70   OUTPUT OF FPLOT16 FILES                                   BUGSV.49    
C                                                                          BUGSV.50    
C                                                                          VAROT.11    
*CALL PARAM1                                                               VAROT.12    
*CALL PARAM2                                                               VAROT.13    
*CALL GRIDP                                                                VAROT.14    
*CALL SPECTR                                                               VAROT.15    
*CALL LEGAU                                                                VAROT.16    
*CALL BLANK                                                                VAROT.17    
*CALL COMFFT                                                               VAROT.18    
C                                                                          VAROT.19    
C     AFTER INITIALISING, GOES STRAIGHT INTO TIMESTEP LOOP                 VAROT.20    
C     AND FIRST HAS TO CALCULATE TRANSFORMS                                VAROT.21    
C                                                                          VAROT.22    
      CALL INITAL                                                          VAROT.23    
1     CONTINUE                                                             VAROT.24    
      DO 10 I=1,IGA                                                        VAROT.25    
10    ZT(I)=0.                                                             VAROT.26    
      JL=1                                                                 VAROT.27    
      DO 20 IH=1,JG                                                        VAROT.28    
      IF(JGL.EQ.1)THEN                                                     VAROT.29    
      READ(25)ALP,DALP,RLP,RDLP                                            VAROT.30    
      READ(26)GSG,GSX,GSY                                                  VAROT.31    
      READ(27)UCHI,VCHI,DG                                                 VAROT.32    
      ENDIF                                                                VAROT.33    
      CALL LTI                                                             VAROT.34    
      CALL FFT991(ZG,WORK,TRIG,IFAX,1,MGPP,MG,NTWG,1)                      VAROT.35    
      IF(KOUNTO.NE.0)THEN                                                  VAROT.36    
       IF(KOUNT.EQ.0.OR.                                                   VAROT.37    
     : (KITS.EQ.0.AND.(KOUNT/KOUNTO)*KOUNTO.EQ.KOUNT).OR.                  VAROT.38    
     : (KITS.NE.0.AND.KOUNT.GT.(KITS-1).AND.                               VAROT.39    
     : ((KOUNT-KITS+1)/KOUNTO)*KOUNTO.EQ.(KOUNT-KITS+1)))THEN              VAROT.40    
         WRITE(28)ZG,UPSI,VPSI                                             VAROT.41    
       ENDIF                                                               VAROT.42    
      ENDIF                                                                VAROT.43    
      JH=IH                                                                VAROT.44    
      CALL MGRMLT                                                          VAROT.45    
      CALL FFT991(UZG,WORK,TRIG,IFAX,1,MGPP,MG,NTGW,-1)                    VAROT.46    
      CALL LT                                                              VAROT.47    
20    JL=JL+JINC                                                           VAROT.48    
      IF(JGL.EQ.1)THEN                                                     VAROT.49    
        REWIND 25                                                          VAROT.50    
        REWIND 26                                                          VAROT.51    
        REWIND 27                                                          VAROT.52    
      ENDIF                                                                VAROT.53    
      REWIND 28                                                            VAROT.54    
      IF(KOUNTO.NE.0)THEN                                                  VAROT.55    
       IF(KOUNT.EQ.0.OR.                                                   VAROT.56    
     : (KITS.EQ.0.AND.(KOUNT/KOUNTO)*KOUNTO.EQ.KOUNT).OR.                  VAROT.57    
     : (KITS.NE.0.AND.KOUNT.GT.(KITS-1).AND.                               VAROT.58    
     : ((KOUNT-KITS+1)/KOUNTO)*KOUNTO.EQ.(KOUNT-KITS+1)))THEN              VAROT.59    
          PRINT*,' KOUNT,DAY ',KOUNT,DAY                                   VAROT.60    
          CALL OUTFLD(0)                                                   VAROT.61    
          CALL OUTFLD(12)                                                  VAROT.62    
      CALL OUTFLD(13)                                                      BUGSV.136   
      CALL OUTFLD(14)                                                      BUGSV.137   
       ENDIF                                                               VAROT.63    
      ENDIF                                                                VAROT.64    
C                                                                          VAROT.65    
C     AND NOW FOR TIMESTEP                                                 VAROT.66    
C                                                                          VAROT.67    
      IF(KOUNT-KTOTAL)9,99,99                                              VAROT.68    
9     CONTINUE                                                             VAROT.69    
      CALL ENERGY                                                          BUGSV.138   
      KOUNT=KOUNT+1                                                        VAROT.70    
      RKOUNT=KOUNT                                                         VAROT.71    
      IF(KOUNT.EQ.1.AND.KITS.GT.0)DAY=DAY+DELT/PI2                         VAROT.72    
      DAY=DAY+DELT/PI2                                                     VAROT.73    
      CALL DIFUSE                                                          VAROT.74    
      CALL TSTEP                                                           VAROT.75    
      GO TO 1                                                              VAROT.76    
99    REWIND 24                                                            VAROT.77    
      WRITE(24)RKOUNT,RNTAPE,DAY,Z,RNTAPE,ZMI,RNTAPE                       VAROT.78    
      IF(LUTF)call endutf(65)                                              BUGSV.146   
      STOP                                                                 VAROT.80    
      END                                                                  VAROT.81    
*DECK INITAL                                                               INITAL.1     
      SUBROUTINE INITAL                                                    INITAL.2     
C                                                                          INITAL.3     
C     INITAL IS NOW JUST A ROUTINE THAT CALLS OTHER INITIALISATION         INITAL.4     
C        ROUTINES. NOTE THAT THROUGHOUT, CHANNELS 5 AND 6 ARE FOR          INITAL.5     
C           INPUT AND OUTPUT RESP.                                         INITAL.6     
C                                                                          INITAL.7     
*CALL PARAM1                                                               INITAL.8     
*CALL PARAM2                                                               INITAL.9     
*CALL GRIDP                                                                INITAL.10    
*CALL SPECTR                                                               INITAL.11    
*CALL LEGAU                                                                INITAL.12    
*CALL BLANK                                                                INITAL.13    
*CALL COMFFT                                                               INITAL.14    
*CALL INPB                                                                 INITAL.15    
C                                                                          INITAL.16    
C                                                                          INITAL.17    
C                                                                          INITAL.18    
      CALL INISET                                                          INITAL.19    
      READ(5,INPB)                                                         INITAL.20    
      CALL INIDIS                                                          INITAL.21    
      CALL INIFFT                                                          INITAL.22    
      CALL INIGAU                                                          INITAL.23    
      CALL INITIM                                                          INITAL.24    
      IF(LUTF)CALL INIUTF(' Reading Barotropic model ',65)                 BUGSV.147   
      CALL INIGS                                                           INITAL.26    
      CALL INIRES                                                          INITAL.27    
      CALL INIDIV                                                          INITAL.28    
      CALL INIPSI                                                          INITAL.29    
      WRITE(6,INPB)                                                        INITAL.30    
      RETURN                                                               INITAL.31    
      END                                                                  INITAL.32    
*DECK INISET                                                               INISET.1     
      SUBROUTINE INISET                                                    INISET.2     
C                                                                          INISET.3     
C     SETS UP ALL FIXED VALUES AND SET NAMELIST VARIABLES TO THEIR         INISET.4     
C        DEFAULT SETTINGS                                                  INISET.5     
C                                                                          INISET.6     
*CALL PARAM1                                                               INISET.7     
*CALL PARAM2                                                               INISET.8     
*CALL BLANK                                                                INISET.9     
      RNTAPE=0.                                                            INISET.12    
      TSPD=24.                                                             INISET.13    
      KITS=0                                                               INISET.14    
      KOUNT=0                                                              INISET.15    
      KTOTAL=30*NINT(TSPD)                                                 INISET.16    
      DAY=0.                                                               INISET.17    
      TDISS=0.                                                             INISET.18    
      NDEL=8                                                               INISET.19    
      RESTIM=0.                                                            INISET.20    
      PNU=0.00                                                             INISET.21    
      PNU21=1.-2.*PNU                                                      INISET.22    
      WW=7.292E-5                                                          INISET.23    
      RADEA=6371000.                                                       INISET.24    
      CV=RADEA*WW                                                          INISET.25    
      GA=9.81                                                              INISET.26    
      EZ=1./SQRT(0.375)                                                    INISET.27    
      NLEVD=0                                                              INISET.28    
      NLEVZ=4                                                              INISET.29    
      LFIXZN=.FALSE.                                                       BUGSV.54    
      LDIVZN=.FALSE.                                                       BUGSV.55    
      LOLD=.FALSE.                                                         BUGSV.56    
      LCOR=.FALSE.                                                         BUGSV.57    
C                                                                          INISET.32    
C     NOW SET VARIABLES CONTROLLING OUTPUT                                 INISET.33    
C                                                                          INISET.34    
      KOUNTO=NINT(TSPD)                                                    INISET.35    
      DO 50 L=1,IOUTL                                                      INISET.36    
50    LSPO(L)=.TRUE.                                                       INISET.37    
      LUTF=.TRUE.                                                          INISET.38    
      LPRINT=.TRUE.                                                        INISET.39    
      NLAT=JG                                                              INISET.40    
      DO 60 IOUT=1,IOUTL                                                   BUGSV.116   
60    SGINC(IOUT)=-200.                                                    BUGSV.117   
      SGINC(1)=500.                                                        BUGSV.118   
      SGINC(4)=0.5                                                         BUGSV.119   
      SGINC(5)=0.5                                                         BUGSV.120   
      SGINC(6)=1.E-6                                                       BUGSV.121   
      NLONG=MG                                                             INISET.41    
C                                                                          INISET.42    
C     NOW PERFORM CHECKS  AND SETUP ARRAYS                                 INISET.43    
C                                                                          INISET.44    
      NWJCH=0                                                              INISET.45    
      DO 10 MP=1,MM,MOCT                                                   INISET.46    
      DO 10 JP=MP,NN,2                                                     INISET.47    
10    NWJCH=NWJCH+1                                                        INISET.48    
      IF(NWJCH.NE.NWJ2)THEN                                                INISET.49    
      PRINT*,' ABORT: NWJ2 IS NOT CORRECTLY SET '                          INISET.50    
      PRINT*,' IT SHOULD BE ',NWJCH,' BUT IS SPECIFIED AS ',NWJ2           INISET.51    
      CALL ABORT                                                           INISET.52    
      ENDIF                                                                INISET.53    
      DO 20 NP=1,NNP                                                       INISET.54    
      SQ(NP)=NP*(NP-1)                                                     INISET.55    
      IF(NP.EQ.1)THEN                                                      INISET.56    
      RSQ(NP)=1.                                                           INISET.57    
      ELSE                                                                 INISET.58    
      RSQ(NP)=1./SQ(NP)                                                    INISET.59    
      ENDIF                                                                INISET.60    
20    CONTINUE                                                             INISET.61    
      RETURN                                                               INISET.62    
      END                                                                  INISET.63    
*DECK INIDIS                                                               INIDIS.1     
      SUBROUTINE INIDIS                                                    INIDIS.2     
C                                                                          INIDIS.3     
C     SETS UP DISSIPATION OF THE FORM DEL N, AND RAYLEIGH FRICTION         INIDIS.4     
C                                                                          INIDIS.5     
C                                                                          INIDIS.6     
*CALL PARAM1                                                               INIDIS.7     
*CALL PARAM2                                                               INIDIS.8     
*CALL BLANK                                                                INIDIS.9     
C                                                                          INIDIS.10    
C                                                                          INIDIS.11    
C                                                                          INIDIS.12    
      IF(RESTIM.NE.0.)RESTIM=1./(PI2*RESTIM)                               INIDIS.13    
      AKK=0.                                                               INIDIS.14    
      IF(TDISS.EQ.0.)THEN                                                  INIDIS.15    
         PRINT*,' NO HYPER DIFFUSION '                                     INIDIS.16    
      ELSE                                                                 INIDIS.17    
         IF(TDISS.LT.0.)TDISS=-TDISS/24.                                   INIDIS.18    
         AKK=1./(PI2*TDISS*((NN*(NN+1))**(NDEL/2.)))                       BUGS2.2     
         PRINT*,'  HYPER DIFFUSION HAS NDEL= ',NDEL,' AND TDISS= ',        INIDIS.20    
     :    TDISS,' DAYS'                                                    INIDIS.21    
         PRINT*,' THIS IS EQUIVALENT TO ',AKK*WW*(RADEA**NDEL)             INIDIS.22    
     :   ,' IN MKS UNITS '                                                 INIDIS.23    
      ENDIF                                                                INIDIS.24    
      DO 10 NP=1,NNP                                                       INIDIS.25    
10    AK(NP)=AKK*(SQ(NP)**(NDEL/2))                                        INIDIS.26    
      RETURN                                                               INIDIS.27    
      END                                                                  INIDIS.28    
*DECK INIFFT                                                               INIFFT.1     
      SUBROUTINE INIFFT                                                    INIFFT.2     
C                                                                          INIFFT.3     
C     SETS UP ARRAYS FOR USE IN FFT ROUTINES ETC                           INIFFT.4     
C                                                                          INIFFT.5     
C                                                                          INIFFT.6     
*CALL PARAM1                                                               INIFFT.7     
*CALL PARAM2                                                               INIFFT.8     
*CALL COMFFT                                                               INIFFT.9     
*CALL POLYNO                                                               INIFFT.10    
C                                                                          INIFFT.11    
C                                                                          INIFFT.12    
C                                                                          INIFFT.13    
      NTWG=3*NHEM                                                          INIFFT.14    
      NTGW=3*NHEM                                                          INIFFT.15    
      DO 10 I=1,IGL                                                        INIFFT.16    
10    CMPA(I)=0.                                                           INIFFT.17    
      NROW=0                                                               INIFFT.18    
      DO 20 MP=1,MM,MOCT                                                   INIFFT.19    
      NROW=NROW+1                                                          INIFFT.20    
20    CMPA(NROW)=CMPLX(0.,FLOAT(MP-1))                                     INIFFT.21    
      IF(NHEM.EQ.2)THEN                                                    INIFFT.22    
      NROW=0                                                               INIFFT.23    
      DO 30 MP=1,MM,MOCT                                                   INIFFT.24    
      NROW=NROW+1                                                          INIFFT.25    
30    CMPA(NROW+IDL)=CMPA(NROW)                                            INIFFT.26    
      ENDIF                                                                INIFFT.27    
      CALL FAX(IFAX,MG,3)                                                  INIFFT.28    
      CALL FFTRIG(TRIG,MG,3)                                               INIFFT.29    
      RETURN                                                               INIFFT.30    
      END                                                                  INIFFT.31    
*DECK INIGAU                                                               INIGAU.1     
      SUBROUTINE INIGAU                                                    INIGAU.2     
C                                                                          INIGAU.3     
C     SETS UP VARIABLES FOR GAUSSIAN LATITUDES AND THE                     INIGAU.4     
C        LEGENDRE FUNCTIONS.                                               INIGAU.5     
C                                                                          INIGAU.6     
*CALL PARAM1                                                               INIGAU.7     
*CALL PARAM2                                                               INIGAU.8     
*CALL LEGAU                                                                INIGAU.9     
*CALL BLANK                                                                INIGAU.10    
C                                                                          INIGAU.11    
C                                                                          INIGAU.12    
C                                                                          INIGAU.13    
      IF(JGL.NE.1.AND.JGL.NE.JG)THEN                                       INIGAU.14    
      PRINT*,' JGL (SET AT ',JGL,') MUST EQUAL 1 OR JG ( ',JG,')'          INIGAU.15    
      CALL ABORT                                                           INIGAU.16    
      ENDIF                                                                INIGAU.17    
      JINC=1                                                               INIGAU.18    
      IF(JGL.EQ.1)JINC=0                                                   INIGAU.19    
      JL=1                                                                 INIGAU.20    
      DO 10 J=1,JG                                                         INIGAU.21    
      CALL GWTLT(SIT,WEIGHT,J,JG)                                          INIGAU.22    
      CSJ=1.-SIT*SIT                                                       INIGAU.23    
      RCSJ=1./CSJ                                                          INIGAU.24    
      SI(J)=SIT                                                            INIGAU.25    
      CS(J)=    CSJ                                                        INIGAU.26    
      ALAT(J)=ATAN(SIT*SQRT(RCSJ))*180./PI                                 INIGAU.27    
      AW(J)=WEIGHT*RCSJ*2.                                                 INIGAU.28    
      CALL LGNDRE                                                          INIGAU.29    
      IP=0                                                                 INIGAU.30    
      DO 20 MP=1,MM,MOCT                                                   INIGAU.31    
      N=MP-1                                                               INIGAU.32    
      MAX=MP+((NN-MP)/2)*2+1                                               INIGAU.33    
CDIR$ IVDEP                                                                INIGAU.34    
      DO 30 JP=MP,MAX                                                      INIGAU.35    
      IP=IP+1                                                              INIGAU.36    
      N=N+1                                                                INIGAU.37    
      RLP(IP,JL)=-RSQ(N)*ALP(IP,JL)                                        INIGAU.38    
      RDLP(IP,JL)=-RSQ(N)*DALP(IP,JL)                                      INIGAU.39    
30    CONTINUE                                                             INIGAU.40    
20    CONTINUE                                                             INIGAU.41    
      IF(JGL.EQ.1)WRITE(25)ALP,DALP,RLP,RDLP                               INIGAU.42    
10    JL=JL+JINC                                                           INIGAU.43    
      IF(JGL.EQ.1)REWIND 25                                                INIGAU.44    
      PRINT*,' GAUSSIAN LATITUDES '                                        INIGAU.45    
      PRINT 1000,ALAT                                                      INIGAU.46    
1000  FORMAT(1X,10F8.3)                                                    INIGAU.47    
      RETURN                                                               INIGAU.48    
      END                                                                  INIGAU.49    
*DECK INITIM                                                               INITIM.1     
      SUBROUTINE INITIM                                                    INITIM.2     
C                                                                          INITIM.3     
C     SETS UP TIME STEP VARIABLES                                          INITIM.4     
C                                                                          INITIM.5     
*CALL PARAM1                                                               INITIM.6     
*CALL PARAM2                                                               INITIM.7     
*CALL BLANK                                                                INITIM.8     
C                                                                          INITIM.9     
C                                                                          INITIM.10    
C                                                                          INITIM.11    
      IF(KTOTAL.EQ.0)THEN                                                  INITIM.12    
      PRINT*,' KTOTAL EQUAL TO ZERO '                                      INITIM.13    
      CALL ABORT                                                           INITIM.14    
      ENDIF                                                                INITIM.15    
      DELT=PI2/TSPD                                                        INITIM.16    
      IF(KITS.GT.0)DELT=DELT*(0.5**KITS)                                   INITIM.17    
      DELT2=DELT+DELT                                                      INITIM.18    
      IF(KTOTAL.LT.0)THEN                                                  BUGSV.139   
         IF(KITS.EQ.0)THEN                                                 BUGSV.140   
           KTOTAL=-KTOTAL*TSPD                                             BUGSV.141   
         ELSE                                                              BUGSV.142   
           KTOTAL=-KTOTAL*TSPD+KITS-1                                      BUGSV.143   
         ENDIF                                                             BUGSV.144   
       ENDIF                                                               BUGSV.145   
      RETURN                                                               INITIM.20    
      END                                                                  INITIM.21    
*DECK INIGS                                                                INIGS.1     
      SUBROUTINE INIGS                                                     INIGS.2     
C                                                                          INIGS.3     
C     SETS UP OROGRAPHY VARIABLES, CALCULATES DGS/DX AND DGS/DY            INIGS.4     
C                                                                          INIGS.5     
C                                                                          INIGS.6     
*CALL PARAM1                                                               INIGS.7     
*CALL PARAM2                                                               INIGS.8     
*CALL GRIDP                                                                INIGS.9     
*CALL SPECTR                                                               INIGS.10    
*CALL LEGAU                                                                INIGS.11    
*CALL BLANK                                                                INIGS.12    
*CALL COMFFT                                                               INIGS.13    
C                                                                          BUGSV.81    
C      INITILISE FIELDS TO ZERO AND NONDIMESIONALISE                       BUGSV.82    
C                                                                          BUGSV.83    
      PRINT*,' SCALE HEIGHT IN KMS ',HGT                                   BUGSV.84    
      IF(HGT.NE.0.)HGT=1./(HGT*1000./(CV*CV/GA))                           BUGSV.85    
      PRINT*,' NONDIMENSIONAL INVERSE SCALE HEIGHT ',HGT                   BUGSV.86    
      DO 10 I=1,IGA                                                        INIGS.14    
10    Z(I)=0.                                                              INIGS.15    
      DO 20 JL=1,JGL                                                       INIGS.16    
      DO 20 I=1,IGC                                                        INIGS.17    
      GSX(I,JL)=0.                                                         INIGS.18    
      GSY(I,JL)=0.                                                         INIGS.19    
20    GSG(I,JL)=0.                                                         INIGS.20    
C                                                                          INIGS.21    
C     HERE READ IN SPECTRAL COEFFICIENTS OF OROGRAPHY IF REQUIRED          INIGS.22    
C        IF THE HEIGHT IS SET TO ZERO, NO POINT DOING  ANYTHING            INIGS.23    
C                                                                          INIGS.24    
      IF(HGT.EQ.0.)THEN                                                    INIGS.25    
        IF(JGL.EQ.1)THEN                                                   INIGS.26    
        DO 27 JH=1,JG                                                      INIGS.27    
27      WRITE(26)GSG,GSX,GSY                                               INIGS.28    
        ENDIF                                                              INIGS.29    
      ELSE                                                                 INIGS.30    
        RMS=0.                                                             INIGS.31    
        DO 25 I=1,IGA                                                      INIGS.32    
25      RMS=RMS+CABS(Z(I))                                                 INIGS.33    
        IF(RMS.EQ.0.)THEN                                                  INIGS.34    
          IF(JGL.EQ.1)THEN                                                 INIGS.35    
          DO 28 JH=1,JG                                                    INIGS.36    
28        WRITE(26)GSG                                                     INIGS.37    
          ENDIF                                                            INIGS.38    
        ELSE                                                               INIGS.39    
          JL=1                                                             INIGS.40    
          DO 30 JH=1,JG                                                    INIGS.41    
          IF(JGL.EQ.1) READ(25)ALP,DALP,RLP,RDLP                           BUGS2.3     
          CALL HEXP(Z,GSG(1,JL),1,2)                                       INIGS.42    
          CALL FFT991(GSG(1,JL),WORK,TRIG,IFAX,1,MGPP,MG,NHEM,1)           INIGS.43    
          IF(JGL.EQ.1)WRITE(26)GSG                                         INIGS.44    
30        JL=JL+JINC                                                       INIGS.45    
          IF(JGL.EQ.1) REWIND 25                                           BUGS2.4     
        ENDIF                                                              INIGS.47    
        IF (JGL.EQ.1) REWIND 26                                            BUGS2.5     
C                                                                          INIGS.48    
C     IF GRID POINT IS TO BE READ, THEN IT SHOULD BE  READ IN              INIGS.49    
C        HERE AND IF JGL.EQ.1 COPIED TO CHANNEL 26                         INIGS.50    
C                                                                          INIGS.51    
        RMS=0.                                                             INIGS.52    
        JL=1                                                               INIGS.53    
        DO 32 JH=1,JG                                                      INIGS.54    
        IF(JGL.EQ.1)READ(26)GSG                                            INIGS.55    
        DO 33 I=1,IGC                                                      INIGS.56    
33      RMS=RMS+ABS(GSG(I,JL))                                             INIGS.57    
32      JL=JL+JINC                                                         INIGS.58    
        IF(JGL.EQ.1)REWIND 26                                              INIGS.59    
        IF(RMS.EQ.0.)THEN                                                  INIGS.60    
          IF(JGL.EQ.1)THEN                                                 INIGS.61    
          DO 34 JH=1,JG                                                    INIGS.62    
34        WRITE(26)GSG,GSX,GSY                                             INIGS.63    
          ENDIF                                                            INIGS.64    
        ELSE                                                               INIGS.65    
C                                                                          INIGS.66    
C     NEW FORMULATION OF OROGRAPHIC FORCING INCLUDES INTERACTIONS          INIGS.67    
C             WITH ABSOLUTE VORTICITY AND SIMPLE EXTENSION                 INIGS.68    
C                    TO INCLUDE DIVEREGENCE EFFECTS                        INIGS.69    
C                                                                          INIGS.70    
      DO 35 I=1,IGA                                                        INIGS.71    
35    Z(I)=0.                                                              INIGS.72    
      JL=1                                                                 INIGS.73    
      DO 40 IH=1,JG                                                        INIGS.74    
      JH=IH                                                                INIGS.75    
      IF(JGL.EQ.1) THEN                                                    BUGS2.6     
        READ(25)ALP,DALP,RLP,RDLP                                          BUGS2.7     
        READ(26)GSG                                                        BUGS2.8     
      ENDIF                                                                BUGS2.9     
      CALL FFT991(GSG(1,JL),WORK,TRIG,IFAX,1,MGPP,MG,NHEM,-1)              INIGS.77    
      CALL HANAL(GSG(1,JL),Z,1,2)                                          INIGS.78    
40    JL=JL+JINC                                                           INIGS.79    
      IF(JGL.EQ.1) THEN                                                    BUGS2.10    
        REWIND 25                                                          BUGS2.11    
        REWIND 26                                                          BUGS2.12    
      ENDIF                                                                BUGS2.13    
      JL=1                                                                 INIGS.81    
      DO 50 JH=1,JG                                                        INIGS.82    
      IF(JGL.EQ.1) READ(25)ALP,DALP,RLP,RDLP                               BUGS2.14    
      CALL HEXP(Z,GSG(1,JL),1,2)                                           INIGS.83    
      CALL HEXP(Z,GSY(1,JL),1,4)                                           INIGS.84    
      CALL EIM(GSG(1,JL),GSX(1,JL),1)                                      BUGSV.79    
      CALL FFT991(GSG(1,JL),WORK,TRIG,IFAX,1,MGPP,MG,NHEM,1)               INIGS.86    
      CALL FFT991(GSX(1,JL),WORK,TRIG,IFAX,1,MGPP,MG,NHEM,1)               INIGS.87    
      CALL FFT991(GSY(1,JL),WORK,TRIG,IFAX,1,MGPP,MG,NHEM,1)               INIGS.88    
      IF(JGL.EQ.1)WRITE(26)GSG,GSX,GSY                                     INIGS.89    
50    JL=JL+JINC                                                           INIGS.90    
      IF(JGL.EQ.1) THEN                                                    BUGS2.15    
        REWIND 25                                                          BUGS2.16    
        REWIND 26                                                          BUGS2.17    
      ENDIF                                                                BUGS2.18    
      CALL OUTFLD(1)                                                       BUGSV.87    
      CALL OUTFLD(2)                                                       BUGSV.88    
      CALL OUTFLD(3)                                                       BUGSV.89    
      ENDIF                                                                INIGS.92    
      IF (JGL.EQ.1) REWIND 26                                              BUGS2.19    
      ENDIF                                                                INIGS.93    
      IF (JGL.EQ.1) REWIND 26                                              BUGS2.20    
      RETURN                                                               INIGS.94    
      END                                                                  INIGS.95    
*DECK INIRES                                                               INIRES.1     
      SUBROUTINE INIRES                                                    INIRES.2     
C                                                                          INIRES.3     
C     SETS UP VORTICITY RESTORATION ARRAY                                  INIRES.4     
C                                                                          INIRES.5     
*CALL PARAM1                                                               INIRES.6     
*CALL PARAM2                                                               INIRES.7     
*CALL SPECTR                                                               INIRES.8     
C                                                                          INIRES.9     
C                                                                          INIRES.10    
C                                                                          INIRES.11    
      DO 10 I=1,IGA                                                        INIRES.12    
10    ZRES(I)=0.                                                           INIRES.13    
      RETURN                                                               INIRES.14    
      END                                                                  INIRES.15    
*DECK INIDIV                                                               INIDIV.1     
      SUBROUTINE INIDIV                                                    INIDIV.2     
C                                                                          INIDIV.3     
C     READ IN DIVERGENCE SPECTRAL COEFFICIENTS AND CALCULATES              INIDIV.4     
C        GRID POINT FIELDS OF D AND U CHI V CHI                            INIDIV.5     
C                                                                          INIDIV.6     
*CALL PARAM1                                                               INIDIV.7     
*CALL PARAM2                                                               INIDIV.8     
*CALL GRIDP                                                                INIDIV.9     
*CALL SPECTR                                                               INIDIV.10    
*CALL LEGAU                                                                INIDIV.11    
*CALL BLANK                                                                INIDIV.12    
*CALL COMFFT                                                               INIDIV.13    
C                                                                          INIDIV.14    
C                                                                          INIDIV.15    
C                                                                          INIDIV.16    
      DO 10 I=1,IGA                                                        INIDIV.17    
10    Z(I)=0.                                                              INIDIV.18    
      IF(NLEVD.GT.0)THEN                                                   INIDIV.19    
        READ(10)RN1,RN2,RN3,((Z(I),I=1,IGA),L=1,NLEVD)                     INIDIV.20    
        BACKSPACE 10                                                       INIDIV.21    
        PRINT*,' RKOUNT,DAY,RNTAPE FROM INPUT FILE ',RN1,RN2,RN3           INIDIV.22    
      ELSEIF(NLEVD.LT.0)THEN                                               INIDIV.23    
        PRINT*,' ELLIP. BLOB '                                             INIDIV.24    
        JL=1                                                               INIDIV.25    
        DO 15 JH=1,JG                                                      INIDIV.26    
        IF(JGL.EQ.1) READ(25)ALP,DALP,RLP,RDLP                             BUGS2.21    
        CALL FORCE(DG(1,JL),1.00,6.,90.,145.,6.E-6/WW)                     INIDIV.27    
        CALL FFT991(DG(1,JL),WORK,TRIG,IFAX,1,MGPP,MG,NHEM,-1)             INIDIV.28    
        CALL HANAL(DG(1,JL),Z,1,2)                                         INIDIV.29    
15      JL=JL+JINC                                                         INIDIV.30    
        IF(JGL.EQ.1) REWIND 25                                             BUGS2.22    
      ELSE                                                                 INIDIV.31    
         PRINT*,' NO DIVERGENCE SET '                                      INIDIV.32    
      ENDIF                                                                INIDIV.33    
      IF(LDIVZN)THEN                                                       INIDIV.34    
        PRINT*,' SET ZONAL MEAN DIVERGENCE EQUAL TO ZERO '                 INIDIV.35    
        DO 18 IHEM=1,NHEM                                                  INIDIV.36    
        IOFF=(IHEM-1)*NWJ2                                                 INIDIV.37    
        DO 18 I=1,IDM                                                      INIDIV.38    
        J=I+IOFF                                                           INIDIV.39    
18      Z(I)=0.                                                            INIDIV.40    
      ENDIF                                                                INIDIV.41    
      JL=1                                                                 INIDIV.42    
      DO 20 JL=1,JGL                                                       INIDIV.43    
      DO 20 I=1,IGC                                                        INIDIV.44    
      DG(I,JL)=0.                                                          INIDIV.45    
      UCHI(I,JL)=0.                                                        INIDIV.46    
20    VCHI(I,JL)=0.                                                        INIDIV.47    
      RMS=0.                                                               INIDIV.48    
      DO 50 I=1,IGA                                                        INIDIV.49    
50    RMS=RMS+CABS(Z(I))                                                   INIDIV.50    
      IF(RMS.NE.0.)THEN                                                    INIDIV.51    
        JL=1                                                               INIDIV.52    
        DO 30 IH=1,JG                                                      INIDIV.53    
        IF(JGL.EQ.1) READ(25)ALP,DALP,RLP,RDLP                             BUGS2.23    
        CALL HEXP(Z,DG(1,JL),1,2)                                          INIDIV.54    
        CALL HEXP(Z,UCHI(1,JL),1,6)                                        INIDIV.55    
        CALL HEXP(Z,VCHI(1,JL),1,8)                                        INIDIV.56    
        CALL EIM(UCHI(1,JL),UCHI(1,JL),1)                                  INIDIV.57    
        CALL FFT991(DG(1,JL),WORK,TRIG,IFAX,1,MGPP,MG,NHEM,1)              INIDIV.58    
        CALL FFT991(UCHI(1,JL),WORK,TRIG,IFAX,1,MGPP,MG,NHEM,1)            INIDIV.59    
        CALL FFT991(VCHI(1,JL),WORK,TRIG,IFAX,1,MGPP,MG,NHEM,1)            INIDIV.60    
        IF(JGL.EQ.1)WRITE(27)UCHI,VCHI,DG                                  INIDIV.61    
30      JL=JL+JINC                                                         INIDIV.62    
        IF(JGL.EQ.1) THEN                                                  BUGS2.24    
          REWIND 25                                                        BUGS2.25    
          REWIND 27                                                        BUGS2.26    
        ENDIF                                                              BUGS2.27    
        CALL OUTFLD(6)                                                     INIDIV.64    
        CALL OUTFLD(4)                                                     INIDIV.65    
        CALL OUTFLD(5)                                                     INIDIV.66    
      ELSE                                                                 INIDIV.67    
        IF(JGL.EQ.1)THEN                                                   INIDIV.68    
        DO 60 J=1,JG                                                       INIDIV.69    
60      WRITE(27)UCHI,VCHI,DG                                              INIDIV.70    
        REWIND 27                                                          INIDIV.71    
        ENDIF                                                              INIDIV.72    
      ENDIF                                                                INIDIV.73    
      RETURN                                                               INIDIV.74    
      END                                                                  INIDIV.75    
*DECK INIPSI                                                               INIPSI.1     
      SUBROUTINE INIPSI                                                    INIPSI.2     
C                                                                          INIPSI.3     
C     SET UP VORTICITY COEFFICIENTS                                        INIPSI.4     
C                                                                          INIPSI.5     
*CALL PARAM1                                                               INIPSI.6     
*CALL PARAM2                                                               INIPSI.7     
*CALL SPECTR                                                               INIPSI.8     
*CALL BLANK                                                                INIPSI.9     
C                                                                          INIPSI.10    
C                                                                          INIPSI.11    
C                                                                          INIPSI.12    
      DO 20 I=1,IGA                                                        INIPSI.13    
20    Z(I)=0.                                                              INIPSI.14    
      IF(NLEVZ.GT.0)THEN                                                   INIPSI.15    
      READ(10)RN1,RN2,RN3,((Z(I),I=1,IGA),L=1,NLEVZ)                       INIPSI.16    
      BACKSPACE 10                                                         INIPSI.17    
      PRINT*,' RKOUNT,DAY,RNTAPE FROM INPUT FILE ',RN1,RN2,RN3             INIPSI.18    
      PRINT*,' ABSOLUTE VORTICITY '                                        INIPSI.19    
      PRINT*,(I,Z(I),I=1,20)                                               INIPSI.20    
      ELSEIF(NLEVZ.LT.0)THEN                                               INIPSI.21    
      Z(1)=EZ*(1.+15.4/CV)                                                 INIPSI.22    
      ELSE                                                                 INIPSI.23    
      PRINT*,' RELATIVE VORTICITY ZERO '                                   INIPSI.24    
      Z(1)=EZ                                                              INIPSI.25    
      ENDIF                                                                INIPSI.26    
      DO 10 I=1,IGA                                                        INIPSI.27    
10    ZMI(I)=Z(I)                                                          INIPSI.28    
      RETURN                                                               INIPSI.29    
      END                                                                  INIPSI.30    
*DECK LTI                                                                  LTI.1     
      SUBROUTINE LTI                                                       LTI.2     
C                                                                          LTI.3     
C     ROUTINE CALLED FOR WAVE TO GRID TRANSFORMS. CALCULATES               LTI.4     
C        HALF TRANSFORMS FOR VORTICITY AND UPSI VPSI                       LTI.5     
C                                                                          LTI.6     
*CALL PARAM1                                                               LTI.7     
*CALL PARAM2                                                               LTI.8     
*CALL GRIDP                                                                LTI.9     
*CALL SPECTR                                                               LTI.10    
*CALL BLANK                                                                LTI.11    
C                                                                          LTI.12    
C                                                                          LTI.13    
C                                                                          LTI.14    
      CALL HEXP(Z,ZG,1,1)                                                  LTI.15    
      Z(1)=Z(1)-EZ                                                         LTI.16    
      CALL HEXP(Z,UPSI,1,7)                                                LTI.17    
      CALL HEXP(Z,VPSI,1,5)                                                LTI.18    
      DO 40 I=1,IGC                                                        LTI.19    
      UPSI(I)=-UPSI(I)                                                     LTI.20    
40    CONTINUE                                                             LTI.21    
      CALL EIM(VPSI,VPSI,1)                                                LTI.22    
      Z(1)=Z(1)+EZ                                                         LTI.23    
      RETURN                                                               LTI.24    
      END                                                                  LTI.25    
*DECK MGRMLT                                                               MGRMLT.1     
      SUBROUTINE MGRMLT                                                    MGRMLT.2     
C                                                                          MGRMLT.3     
C     CALCULATES NONLINEAR TERMS                                           MGRMLT.4     
C                                                                          MGRMLT.5     
*CALL PARAM1                                                               MGRMLT.6     
*CALL PARAM2                                                               MGRMLT.7     
*CALL GRIDP                                                                MGRMLT.8     
*CALL SPECTR                                                               MGRMLT.9     
*CALL LEGAU                                                                MGRMLT.10    
*CALL BLANK                                                                MGRMLT.11    
*CALL COMFFT                                                               MGRMLT.12    
      IOFF=0                                                               MGRMLT.13    
      RCSJ=1./CS(JH)                                                       MGRMLT.14    
      IF(LOLD)THEN                                                         BUGSV.58    
      DO 30 IHEM=1,NHEM                                                    BUGSV.59    
      SIL=2.*(3-2*IHEM)*SI(JH)                                             BUGSV.60    
      DO 40 I=1,MG                                                         BUGSV.61    
      J=I+IOFF                                                             BUGSV.62    
      IF(.NOT.LCOR)SIL=ZG(J)                                               BUGSV.63    
      ZGT=ZG(J)+HGT*SIL*GSG(J,JL)                                          BUGSV.64    
      UZG(J)=-RCSJ*ZGT*UPSI(J)                                             BUGSV.65    
      VZG(J)=-ZGT*VPSI(J)                                                  BUGSV.66    
      ETAVHT(J)=0.                                                         BUGSV.67    
C     UZG(J)=-RCSJ*ZG(J)*(UPSI(J)+UCHI(J,JL))                              BUGSV.68    
C     VZG(J)= -ZG(J)*(VPSI(J)+VCHI(J,JL))                                  BUGSV.69    
C     ETAVHT(J)=-RCSJ*HGT*SIL*(UPSI(J)*GSX(J,JL)+VPSI(J)*GSY(J,JL))        BUGSV.70    
C    : -  HGT*2.*VPSI(J)*GSG(J,JL)                                         BUGSV.71    
40    CONTINUE                                                             BUGSV.72    
      IOFF=MGPP                                                            BUGSV.73    
30    CONTINUE                                                             BUGSV.74    
      ELSE                                                                 BUGSV.75    
      DO 10 IHEM=1,NHEM                                                    MGRMLT.15    
      SIL=2.*(3-2*IHEM)*SI(JH)                                             BUGSV.76    
      DO 20 I=1,MG                                                         MGRMLT.16    
      J=I+IOFF                                                             MGRMLT.17    
      IF(.NOT.LCOR)SIL=ZG(J)                                               BUGSV.77    
      UZG(J)=-RCSJ*ZG(J)*(UPSI(J)+UCHI(J,JL))                              MGRMLT.18    
      VZG(J)=-ZG(J)*(VPSI(J)+VCHI(J,JL))                                   MGRMLT.19    
      ETAVHT(J)=-HGT*RCSJ*SIL*(UPSI(J)*GSX(J,JL)+VPSI(J)*GSY(J,JL))        BUGSV.80    
20    CONTINUE                                                             MGRMLT.21    
      IOFF=MGPP                                                            MGRMLT.22    
10    CONTINUE                                                             MGRMLT.23    
      ENDIF                                                                BUGSV.78    
      RETURN                                                               MGRMLT.24    
      END                                                                  MGRMLT.25    
*DECK LT                                                                   LT.1     
      SUBROUTINE LT                                                        LT.2     
C                                                                          LT.3     
C     CALCULATES TRANSFORMS FROM GRID TO WAVE                              LT.4     
C                                                                          LT.5     
*CALL PARAM1                                                               LT.6     
*CALL PARAM2                                                               LT.7     
*CALL GRIDP                                                                LT.8     
*CALL SPECTR                                                               LT.9     
*CALL LEGAU                                                                LT.10    
*CALL BLANK                                                                LT.11    
C                                                                          LT.12    
      CALL EIM(UZG,UZG,1)                                                  LT.13    
      CALL HANAL(UZG,ZT,1,1)                                               LT.14    
      CALL HANAL(VZG,ZT,1,3)                                               LT.15    
      CALL HANAL(ETAVHT,ZT,1,1)                                            LT.16    
      RETURN                                                               LT.17    
      END                                                                  LT.18    
*DECK DIFUSE                                                               DIFUSE.1     
      SUBROUTINE DIFUSE                                                    DIFUSE.2     
C                                                                          DIFUSE.3     
C     ADDS DISSIPATION TO ADIABATIC TENDENCIES                             DIFUSE.4     
C                                                                          DIFUSE.5     
*CALL PARAM1                                                               DIFUSE.6     
*CALL PARAM2                                                               DIFUSE.7     
*CALL GRIDP                                                                DIFUSE.8     
*CALL SPECTR                                                               DIFUSE.9     
*CALL LEGAU                                                                DIFUSE.10    
*CALL BLANK                                                                DIFUSE.11    
*CALL COMFFT                                                               DIFUSE.12    
C                                                                          DIFUSE.13    
C                                                                          DIFUSE.14    
C                                                                          DIFUSE.15    
      ZMI(1)=ZMI(1)-EZ                                                     DIFUSE.16    
      IF(AK(2).NE.0)THEN                                                   DIFUSE.17    
      DO 10 IHEM=1,NHEM                                                    DIFUSE.18    
      J=(IHEM-1)*NWJ2                                                      DIFUSE.19    
      DO 10 MP=1,MM,MOCT                                                   DIFUSE.20    
      DO 10 IN=MP,NN,2                                                     DIFUSE.21    
      J=J+1                                                                DIFUSE.22    
      ZT(J)=ZT(J)-AK(IN+2-IHEM)*ZMI(J)                                     DIFUSE.23    
10    CONTINUE                                                             DIFUSE.24    
      ENDIF                                                                DIFUSE.25    
      IF(RESTIM.NE.0.)THEN                                                 DIFUSE.26    
      DO 20 I=1,IGA                                                        DIFUSE.27    
20    ZT(I)=ZT(I)-(ZMI(I)-ZRES(I))*RESTIM                                  DIFUSE.28    
      ENDIF                                                                DIFUSE.29    
      ZMI(1)=ZMI(1)+EZ                                                     DIFUSE.30    
      RETURN                                                               DIFUSE.31    
      END                                                                  DIFUSE.32    
*DECK TSTEP                                                                TSTEP.1     
      SUBROUTINE TSTEP                                                     TSTEP.2     
C                                                                          TSTEP.3     
C     PERFORMS FULL OR SHORT TIMESTEPS, ZONAL MEAN CAN BE FIXED            TSTEP.4     
C                                                                          TSTEP.5     
*CALL PARAM1                                                               TSTEP.6     
*CALL PARAM2                                                               TSTEP.7     
*CALL GRIDP                                                                TSTEP.8     
*CALL SPECTR                                                               TSTEP.9     
*CALL LEGAU                                                                TSTEP.10    
*CALL BLANK                                                                TSTEP.11    
*CALL COMFFT                                                               TSTEP.12    
      COMPLEX ZTEMP                                                        TSTEP.13    
      IF(LFIXZN)THEN                                                       TSTEP.14    
C                                                                          TSTEP.15    
C     ZONAL MEAN FIXED                                                     TSTEP.16    
C                                                                          TSTEP.17    
       DO 30 IHEM=1,NHEM                                                   TSTEP.18    
       II=(IHEM-1)*NWJ2                                                    TSTEP.19    
       DO 30 I=1,IDM                                                       TSTEP.20    
       II=II+1                                                             TSTEP.21    
30     ZT(II)=0.                                                           TSTEP.22    
      ENDIF                                                                TSTEP.23    
      IF((KOUNT-KITS).LE.0)THEN                                            TSTEP.24    
C                                                                          TSTEP.25    
C     SHORT TIME STEP                                                      TSTEP.26    
C                                                                          TSTEP.27    
      DO 10 I=1,IGA                                                        TSTEP.28    
10    Z(I)=ZMI(I)+DELT2*ZT(I)                                              TSTEP.29    
      DELT=2.*DELT                                                         TSTEP.30    
      DELT2=DELT+DELT                                                      TSTEP.31    
      ELSE                                                                 TSTEP.32    
C                                                                          TSTEP.33    
C     FULL TIMESTEP WITH TIME FILTER                                       TSTEP.34    
C                                                                          TSTEP.35    
      DO 20 I=1,IGA                                                        TSTEP.36    
      ZTEMP=ZMI(I)                                                         TSTEP.37    
      ZMI(I)=PNU21*Z(I)+PNU*ZTEMP                                          TSTEP.38    
      Z(I)=ZTEMP+DELT2*ZT(I)                                               TSTEP.39    
20    CONTINUE                                                             TSTEP.40    
      DO 22 I=1,IGA                                                        TSTEP.41    
22    ZMI(I)=ZMI(I)+PNU*Z(I)                                               TSTEP.42    
      ENDIF                                                                TSTEP.43    
      RETURN                                                               TSTEP.44    
      END                                                                  TSTEP.45    
*DECK HEXP                                                                 HEXP.1     
      SUBROUTINE HEXP(SV,GV,NLS,ITYPE)                                     HEXP.2     
C                                                                          HEXP.3     
C     PERFORMS INDIRECT LEGENDRE TRANSFORM FOR A (SET OF) FIELD(S)         HEXP.4     
C     HAVING A TOTAL OF NLS LEVELS, FROM SPECTRAL TO FOURIER SPACE.        HEXP.5     
C     THE TYPE OF FUNCTION AND THENCE OF TRANSFORM IS CHOSEN BY ITYPE      HEXP.6     
C     WITH THE FOLLOWING CURRENTLY DEFINED:                                HEXP.7     
C        ITYPE=1,2   : ALP     : NORMAL TRANSFORM.                         HEXP.8     
C        ITYPE=3,4   : DALP    : Y-DERIVATIVE.                             HEXP.9     
C        ITYPE=5,6   : RLP     : DEL(-2).                                  HEXP.10    
C        ITYPE=7,8   : RDLP    : Y-DERIVATIVE OF DEL(-2).                  HEXP.11    
C     AN EVEN/ODD VALUE OF ITYPE DENOTES A SPECTRAL FIELD OF EVEN/ODD      HEXP.12    
C     SYMMETRY.                                                            HEXP.13    
C                                                                          HEXP.14    
*CALL PARAM1                                                               HEXP.15    
*CALL PARAM2                                                               HEXP.16    
*CALL BLANK                                                                HEXP.17    
*CALL LEGAU                                                                HEXP.18    
*CALL POLYNO                                                               HEXP.19    
      COMPLEX SV(IGA*NLS),GV(IGL*NLS),TEMP                                 HEXP.20    
      REAL ALPN(MJP,JGL,4)                                                 HEXP.21    
      EQUIVALENCE (ALPN(1,1,1),ALP(1,1))                                   HEXP.22    
C                                                                          HEXP.23    
C     PRESET FOURIER ARRAY TO ZERO.                                        HEXP.24    
C                                                                          HEXP.25    
C                                                                          BUGSV.19    
C    CHECK THAT NLS = 1                                                    BUGSV.20    
C                                                                          BUGSV.21    
      IF(NLS.NE.1)THEN                                                     BUGSV.22    
         PRINT*,' NLS = ',NLS,'  MAXIMUM MUST BE 1 '                       BUGSV.23    
         CALL ABORT                                                        BUGSV.24    
      ENDIF                                                                BUGSV.25    
      DO 10 I=1,IGL*NLS                                                    HEXP.26    
   10 GV(I)=0.                                                             HEXP.27    
C                                                                          HEXP.28    
C     USE ITYPE TO DEFINE TRANSFORM TYPE AND SYMMETRY LABELS.              HEXP.29    
C     ISPAR IS SYMMETRY OF SPECTRAL FIELD    = 0 FOR D,T,SP ETC.           HEXP.30    
C                                            = 1 FOR Z.                    HEXP.31    
C     IGPAR IS SYMMETRY OF FOURIER FIELD: SAME AS ISPAR UNLESS TRANSFORM   HEXP.32    
C                                         INVOLVES A D/DY.                 HEXP.33    
C                                                                          HEXP.34    
      IF (ITYPE.LE.0.OR.ITYPE.GE.9) THEN                                   HEXP.35    
         WRITE(2,'(/'' ***ABORT : HEXP CALLED WITH TYPE ='',I5)') ITYPE    HEXP.36    
         CALL ABORT                                                        HEXP.37    
      ENDIF                                                                HEXP.38    
      IALP=(ITYPE+1)/2                                                     HEXP.39    
      ISPAR=MOD(ITYPE,2)                                                   HEXP.40    
      IGPAR=ISPAR                                                          HEXP.41    
      IF (IALP.EQ.2.OR.IALP.EQ.4) IGPAR=1-ISPAR                            HEXP.42    
C                                                                          HEXP.43    
C     CALCULATE POLY ARRAY IN VECTOR LOOP BEFORE MAIN TRANSFORM.           HEXP.44    
C                                                                          HEXP.45    
      DO 30 IHEM=1,NHEM                                                    HEXP.46    
      INC=(IHEM-1)*(1-ISPAR)+(2-IHEM)*ISPAR                                HEXP.47    
      IA=INC-1                                                             HEXP.48    
      DO 20 IP=1,NWJ2                                                      HEXP.49    
      IA=IA+2                                                              HEXP.50    
   20 POLY(IP,IHEM)=ALPN(IA,JL,IALP)                                       HEXP.51    
   30 CONTINUE                                                             HEXP.52    
C                                                                          HEXP.53    
C     PERFORM INVERSE LEGENDRE TRANSFORM FROM SPECTRAL SPACE TO FORM       HEXP.54    
C     THE EVEN AND ODD CONTRIBUTIONS TO THE FOURIER TRANSFORMS.            HEXP.55    
C     SEPARATE CODE FOR NHEM=1,2 TO INCREASE EFFICIENCY.                   HEXP.56    
C                                                                          HEXP.57    
      IF (NHEM.EQ.1) THEN                                                  HEXP.58    
         IM=0                                                              BUGSV.30    
         IP=0                                                              BUGSV.31    
         DO 40 MP=1,MM,MOCT                                                HEXP.61    
         IM=IM+1                                                           HEXP.62    
         DO 40 IN=MP,NN,2                                                  HEXP.63    
         IP=IP+1                                                           HEXP.64    
40       GV(IM) = GV(IM) + POLY(IP,1)*SV(IP)                               BUGSV.32    
      ELSE                                                                 HEXP.67    
         IM=0                                                              BUGSV.33    
         IP=0                                                              BUGSV.34    
         DO 50 MP=1,MM,MOCT                                                HEXP.70    
         IM=IM+1                                                           HEXP.71    
         DO 50 IN=MP,NN,2                                                  HEXP.72    
         IP=IP+1                                                           HEXP.73    
         GV(IM+IDL) = GV(IM+IDL) + POLY(IP,2)*SV(IP+NWJ2)                  BUGSV.35    
50       GV(IM) = GV(IM) + POLY(IP,1)*SV(IP)                               BUGSV.36    
      ENDIF                                                                HEXP.77    
C                                                                          HEXP.78    
C     FOR A GLOBAL RUN, SUM AND DIFFERENCE EVEN AND ODD CONTRIBUTIONS      HEXP.79    
C     TO GIVE THE COMPLETE FOURIER TRANSFORMS AT THE NORTHERN AND          HEXP.80    
C     SOUTHERN LATITUDE ROWS.  SEPARATE CODE FOR EACH SYMMETRY:            HEXP.81    
C        IGPAR=0 : EVEN (IA) PRECEDES ODD (IB).                            HEXP.82    
C        IGPAR=0 : ODD (IA) PRECEDES EVEN (IB).                            HEXP.83    
C                                                                          HEXP.84    
      IF (NHEM.EQ.2) THEN                                                  HEXP.85    
         IF (IGPAR.EQ.0) THEN                                              HEXP.86    
CDIR$ IVDEP                                                                BUGSV.26    
            DO 60 M=1,NWW                                                  HEXP.87    
            IA=M                                                           BUGSV.27    
            IB=IA+IDL                                                      HEXP.92    
            TEMP=GV(IA)                                                    HEXP.93    
            GV(IA)=TEMP+GV(IB)                                             HEXP.94    
            GV(IB)=TEMP-GV(IB)                                             HEXP.95    
   60       CONTINUE                                                       HEXP.96    
         ELSE                                                              HEXP.97    
CDIR$ IVDEP                                                                BUGSV.28    
            DO 70 M=1,NWW                                                  HEXP.98    
            IA=M                                                           BUGSV.29    
            IB=IA+IDL                                                      HEXP.103   
            TEMP=GV(IA)                                                    HEXP.104   
            GV(IA)=GV(IB)+TEMP                                             HEXP.105   
            GV(IB)=GV(IB)-TEMP                                             HEXP.106   
   70       CONTINUE                                                       HEXP.107   
         ENDIF                                                             HEXP.108   
      ENDIF                                                                HEXP.109   
C                                                                          HEXP.110   
      RETURN                                                               HEXP.111   
      END                                                                  HEXP.112   
*DECK HANAL                                                                HANAL.1     
      SUBROUTINE HANAL(GV,SV,NLS,ITYPE)                                    HANAL.2     
C                                                                          HANAL.3     
C     PERFORMS DIRECT LEGENDRE TRANSFORM FOR A (SET OF) FIELD(S)           HANAL.4     
C     HAVING A TOTAL OF NLS LEVELS, FROM FOURIER TO SPECTRAL SPACE.        HANAL.5     
C     THE TYPE OF FUNCTION AND THENCE OF TRANSFORM IS CHOSEN BY ITYPE      HANAL.6     
C     WITH THE FOLLOWING CURRENTLY DEFINED:                                HANAL.7     
C        ITYPE=1,2   : ALP     : NORMAL TRANSFORM.                         HANAL.8     
C        ITYPE=3,4   : DALP    : Y-DERIVATIVE.                             HANAL.9     
C     AN EVEN/ODD VALUE OF ITYPE DENOTES A SPECTRAL FIELD OF EVEN/ODD      HANAL.10    
C     SYMMETRY.                                                            HANAL.11    
C                                                                          HANAL.12    
*CALL PARAM1                                                               HANAL.13    
*CALL PARAM2                                                               HANAL.14    
*CALL BLANK                                                                HANAL.15    
*CALL LEGAU                                                                HANAL.16    
*CALL POLYNO                                                               HANAL.17    
      COMPLEX SV(IGA*NLS),GV(IGL*NLS),TEMP                                 HANAL.18    
      REAL ALPN(MJP,JGL,4)                                                 HANAL.19    
      EQUIVALENCE (ALPN(1,1,1),ALP(1,1))                                   HANAL.20    
C                                                                          HANAL.21    
C     USE ITYPE TO DEFINE TRANSFORM TYPE AND SYMMETRY LABELS.              HANAL.22    
C     ISPAR IS SYMMETRY OF SPECTRAL FIELD    = 0 FOR D,T,SP ETC.           HANAL.23    
C                                            = 1 FOR Z.                    HANAL.24    
C     IGPAR IS SYMMETRY OF FOURIER FIELD: SAME AS ISPAR UNLESS TRANSFORM   HANAL.25    
C                                         INVOLVES A D/DY.                 HANAL.26    
C                                                                          HANAL.27    
C                                                                          BUGSV.1     
C    CHECK THAT NLS = 1                                                    BUGSV.2     
C                                                                          BUGSV.3     
      IF(NLS.NE.1)THEN                                                     BUGSV.4     
         PRINT*,' NLS = ',NLS,'  MAXIMUM MUST BE 1 '                       BUGSV.5     
         CALL ABORT                                                        BUGSV.6     
      ENDIF                                                                BUGSV.7     
      IF (ITYPE.LE.0.OR.ITYPE.GE.5) THEN                                   HANAL.28    
         WRITE(2,'(/'' ***ABORT : HANAL CALLED WITH TYPE ='',I5)') ITYPE   HANAL.29    
         CALL ABORT                                                        HANAL.30    
      ENDIF                                                                HANAL.31    
      IALP=(ITYPE+1)/2                                                     HANAL.32    
      ISPAR=MOD(ITYPE,2)                                                   HANAL.33    
      IGPAR=ISPAR                                                          HANAL.34    
      IF (IALP.EQ.2) IGPAR=1-ISPAR                                         HANAL.35    
C                                                                          HANAL.36    
C     FOR A GLOBAL RUN, SUM AND DIFFERENCE THE COMPLETE FOURIER            HANAL.37    
C     TRANSFORMS AT THE NORTHERN AND SOUTHERN LATITUDE ROWS TO GIVE        HANAL.38    
C     THE EVEN AND ODD CONTRIBUTIONS.                                      HANAL.39    
C     SEPARATE CODE FOR EACH SYMMETRY:                                     HANAL.40    
C        IGPAR=0 : EVEN (IA) TO PRECEDE ODD (IB).                          HANAL.41    
C        IGPAR=0 : ODD (IA) TO PRECEDE EVEN (IB).                          HANAL.42    
C                                                                          HANAL.43    
      IF (NHEM.EQ.2) THEN                                                  HANAL.44    
         IF (IGPAR.EQ.0) THEN                                              HANAL.45    
CDIR$ IVDEP                                                                BUGSV.8     
            DO 10 M=1,NWW                                                  HANAL.46    
            IA=M                                                           BUGSV.9     
            IB=IA+IDL                                                      HANAL.51    
            TEMP=GV(IA)                                                    HANAL.52    
            GV(IA)=.5*(TEMP+GV(IB))                                        HANAL.53    
            GV(IB)=.5*(TEMP-GV(IB))                                        HANAL.54    
   10       CONTINUE                                                       HANAL.55    
         ELSE                                                              HANAL.56    
CDIR$ IVDEP                                                                BUGSV.10    
            DO 20 M=1,NWW                                                  HANAL.57    
            IA=M                                                           BUGSV.11    
            IB=IA+IDL                                                      HANAL.62    
            TEMP=GV(IA)                                                    HANAL.63    
            GV(IA)=.5*(TEMP-GV(IB))                                        HANAL.64    
            GV(IB)=.5*(TEMP+GV(IB))                                        HANAL.65    
   20       CONTINUE                                                       HANAL.66    
         ENDIF                                                             HANAL.67    
      ENDIF                                                                HANAL.68    
C                                                                          HANAL.69    
C     SET UP APPROPRIATE GAUSSIAN WEIGHT FOR CURRENT LATITUDE.             HANAL.70    
C     DEPENDS ON TRANSFORM TYPE.                                           HANAL.71    
C     ASSUMES JH IN /LEGAU/ CONTAINS LATITUDE COUNTER FROM CALLING LOOP.   HANAL.72    
C                                                                          HANAL.73    
      IF (IALP.EQ.1) AWT=AW(JH)*CS(JH)                                     HANAL.74    
      IF (IALP.EQ.2) AWT=-AW(JH)                                           HANAL.75    
C                                                                          HANAL.76    
C     CALCULATE POLY ARRAY IN VECTOR LOOP BEFORE MAIN TRANSFORM.           HANAL.77    
C                                                                          HANAL.78    
      DO 30 IHEM=1,NHEM                                                    HANAL.79    
      INC=(IHEM-1)*(1-ISPAR)+(2-IHEM)*ISPAR                                HANAL.80    
      IA=INC-1                                                             HANAL.81    
      DO 30 IP=1,NWJ2                                                      HANAL.82    
      IA=IA+2                                                              HANAL.83    
   30 POLY(IP,IHEM)=AWT*ALPN(IA,JL,IALP)                                   HANAL.84    
C                                                                          HANAL.85    
C     PERFORM DIRECT LEGENDRE TRANSFORM FROM THE EVEN AND ODD              HANAL.86    
C     PARTS OF THE FOURIER TRANSFORMS TO SPECTRAL SPACE.                   HANAL.87    
C     SEPARATE CODE FOR NHEM=1,2 TO INCREASE EFFICIENCY.                   HANAL.88    
C                                                                          HANAL.89    
      IF (NHEM.EQ.1) THEN                                                  HANAL.90    
         IM=0                                                              BUGSV.12    
         IP=0                                                              BUGSV.13    
         DO 40 MP=1,MM,MOCT                                                HANAL.93    
         IM=IM+1                                                           HANAL.94    
         DO 40 IN=MP,NN,2                                                  HANAL.95    
         IP=IP+1                                                           HANAL.96    
40       SV(IP)=SV(IP) + POLY(IP,1)*GV(IM)                                 BUGSV.14    
      ELSE                                                                 HANAL.99    
         IM=0                                                              BUGSV.15    
         IP=0                                                              BUGSV.16    
         DO 50 MP=1,MM,MOCT                                                HANAL.102   
         IM=IM+1                                                           HANAL.103   
         DO 50 IN=MP,NN,2                                                  HANAL.104   
         IP=IP+1                                                           HANAL.105   
         SV(IP+NWJ2)=SV(IP+NWJ2) + POLY(IP,2)*GV(IM+IDL)                   BUGSV.17    
50       SV(IP)=SV(IP) + POLY(IP,1)*GV(IM)                                 BUGSV.18    
      ENDIF                                                                HANAL.109   
C                                                                          HANAL.110   
      RETURN                                                               HANAL.111   
      END                                                                  HANAL.112   
*DECK LGNDRE                                                               LGNDRE.1     
      SUBROUTINE LGNDRE                                                    LGNDRE.2     
C                                                                          LGNDRE.3     
C     CALCULATES LEGNDRE FUNCTIONS                                         LGNDRE.4     
C                                                                          LGNDRE.5     
*CALL PARAM1                                                               LGNDRE.6     
*CALL PARAM2                                                               LGNDRE.7     
*CALL BLANK                                                                LGNDRE.8     
*CALL LEGAU                                                                LGNDRE.9     
      LM=2                                                                 LGNDRE.10    
      ALP(1,JL)=SQRT(.5)                                                   LGNDRE.11    
      F1M=SQRT(1.5)                                                        LGNDRE.12    
      ALP(2,JL)=F1M*SIT                                                    LGNDRE.13    
      DALP(1,JL)=0.                                                        LGNDRE.14    
      DO 1 M1=1,MM                                                         LGNDRE.15    
      M=M1-1                                                               LGNDRE.16    
      AM=M                                                                 LGNDRE.17    
      A2M=M+M                                                              LGNDRE.18    
      E2=SQRT(A2M+3.)                                                      LGNDRE.19    
      IF(M.EQ.0)GOTO 3                                                     LGNDRE.20    
      F2M=-F1M*SQRT(CSJ/A2M)                                               LGNDRE.21    
      F1M=F2M*E2                                                           LGNDRE.22    
      IF(M.NE.MMO)GOTO 1                                                   LGNDRE.23    
      LM=LM+1                                                              LGNDRE.24    
      ALP(LM,JL)=F2M                                                       LGNDRE.25    
      LM=LM+1                                                              LGNDRE.26    
      ALP(LM,JL)=F1M*SIT                                                   LGNDRE.27    
      DALP(LM-1,JL)=-AM*ALP(LM,JL)/E2                                      LGNDRE.28    
    3 M2=M+2                                                               LGNDRE.29    
      MMO=M+MOCT                                                           LGNDRE.30    
      JFM=((NN-M1)/2)*2+M2-1                                               LGNDRE.31    
      IF(JFM.LT.M2)GO TO 5                                                 LGNDRE.32    
      K=LM-M2+1                                                            LGNDRE.33    
      AMSQ=AM*AM                                                           LGNDRE.34    
      DO 4 N=M2,JFM                                                        LGNDRE.35    
      AN=N                                                                 LGNDRE.36    
      AN2=N*N                                                              LGNDRE.37    
      ANM2=(N-1)*(N-1)                                                     LGNDRE.38    
      E1=SQRT((ANM2-AMSQ)/(4.*ANM2-1.))                                    LGNDRE.39    
      E2=SQRT((4.*AN2-1.)/(AN2-AMSQ))                                      LGNDRE.40    
      ALP(K+N,JL)=E2*(SIT*ALP(K+N-1,JL)-E1*ALP(K+N-2,JL))                  LGNDRE.41    
      DALP(K+N-1,JL)= (1.-AN)*ALP(K+N,JL)/E2+AN*E1*ALP(K+N-2,JL)           LGNDRE.42    
    4 CONTINUE                                                             LGNDRE.43    
      LM=LM+JFM-M2+1                                                       LGNDRE.44    
 5    CONTINUE                                                             LGNDRE.45    
      DALP(LM,JL)=-AN*SIT*ALP(LM,JL)+(AN+AN+1.0)*ALP(LM-1,JL)/E2           LGNDRE.46    
    1 CONTINUE                                                             LGNDRE.47    
      RETURN                                                               LGNDRE.48    
      END                                                                  LGNDRE.49    
*DECK OUTFLD                                                               OUTFLD.1     
      SUBROUTINE OUTFLD(IPLOT)                                             OUTFLD.2     
C                                                                          OUTFLD.3     
C     MAIN OUTPUT ROUTINE, OPTIONALLY PRINTS AND CALLS FPLOT16 OUTPUT      OUTFLD.4     
C                                                                          OUTFLD.5     
*CALL PARAM1                                                               OUTFLD.6     
*CALL PARAM2                                                               OUTFLD.7     
*CALL GRIDP                                                                OUTFLD.8     
*CALL SPECTR                                                               OUTFLD.9     
*CALL LEGAU                                                                OUTFLD.10    
*CALL BLANK                                                                OUTFLD.11    
*CALL COMFFT                                                               OUTFLD.12    
C                                                                          OUTFLD.13    
C     IF(IPLOT.EQ.-1)THEN ALL FIELDS                                       OUTFLD.14    
C     IF(IPLOT.EQ.0)THEN MOST TIME DEPENDENT FIELDS, EG 7,8,9,10           OUTFLD.15    
C     IF(IPLOT.GT.0)THEN ONLY FIELDS DESIGNATED BY IPLOT                   OUTFLD.16    
C                                                                          OUTFLD.17    
      REAL GPR(MG,JG,NHEM)                                                 OUTFLD.18    
      CHARACTER LTITLE(IOUTL)*34                                           OUTFLD.19    
C                                                                          OUTFLD.33    
C                                                                          OUTFLD.34    
C                                                                          OUTFLD.35    
      LTITLE(1)=' GS                               '                       BUGSV.122   
      LTITLE(2)=' GSX                              '                       BUGSV.123   
      LTITLE(3)=' GSY                              '                       BUGSV.124   
      LTITLE(4)=' U CHI                            '                       BUGSV.125   
      LTITLE(5)=' V CHI                            '                       BUGSV.126   
      LTITLE(6)=' DIVERGENCE                       '                       BUGSV.127   
      LTITLE(7)=' RELATIVE VORTICITY               '                       BUGSV.128   
      LTITLE(8)=' U PSI                            '                       BUGSV.129   
      LTITLE(9)=' V PSI                            '                       BUGSV.130   
      LTITLE(10)=' STREAM FUNCTION                  '                      BUGSV.131   
      LTITLE(11)=' VORTICITY TENDENCY               '                      BUGSV.132   
      LTITLE(12)=' ROSSBY WAVE SOURCE               '                      BUGSV.133   
      LTITLE(13)=' OROG. FORCING                    '                      BUGSV.134   
      LTITLE(14)=' SPURIOUS SOURCE TERM             '                      BUGSV.135   
      IF(IPLOT.EQ.-1)THEN                                                  OUTFLD.36    
        IO1=1                                                              OUTFLD.37    
        IO2=10                                                             OUTFLD.38    
      ELSEIF(IPLOT.EQ.0)THEN                                               OUTFLD.39    
        IO1=7                                                              OUTFLD.40    
        IO2=10                                                             OUTFLD.41    
      ELSE                                                                 OUTFLD.42    
        IO1=IPLOT                                                          OUTFLD.43    
        IO2=IPLOT                                                          OUTFLD.44    
      ENDIF                                                                OUTFLD.45    
      DO 50 IOUT=IO1,IO2                                                   OUTFLD.46    
      IF(.NOT.LSPO(IOUT)) GO TO 50                                         OUTFLD.47    
      CALL PREP(GPR,IOUT)                                                  OUTFLD.48    
C                                                                          OUTFLD.49    
C                                                                          OUTFLD.50    
C                                                                          OUTFLD.51    
         IX=MG                                                             OUTFLD.52    
         IY=JGG                                                            OUTFLD.53    
         NSKP=34                                                           OUTFLD.54    
         IZPTYP=1                                                          OUTFLD.55    
         IF(NHEM.EQ.1)IZPTYP=4                                             OUTFLD.56    
      IF(LUTF)THEN                                                         OUTFLD.57    
        CALL WTFUTF(GPR,IX,IY,IZPTYP,0,0,0,1,0,0.,0.,SGINC(IOUT),          BUGSV.148   
     :  DAY,LTITLE(IOUT),65,IFAIL)                                         BUGSV.149   
      ENDIF                                                                OUTFLD.59    
      IF(LPRINT)THEN                                                       OUTFLD.60    
      RMG=1./MG                                                            OUTFLD.61    
      FMAX=GPR(1,1,1)                                                      OUTFLD.62    
      FMIN=GPR(1,1,1)                                                      OUTFLD.63    
      DO 32 IHEM=1,NHEM                                                    OUTFLD.64    
      DO 32 JH=1,JG                                                        OUTFLD.65    
      DO 32 I=1,MG                                                         OUTFLD.66    
        IF(FMAX.LT.GPR(I,JH,IHEM))FMAX=GPR(I,JH,IHEM)                      OUTFLD.67    
        IF(FMIN.GT.GPR(I,JH,IHEM))FMIN=GPR(I,JH,IHEM)                      OUTFLD.68    
32    CONTINUE                                                             OUTFLD.69    
      SCALE=ABS(FMAX)                                                      OUTFLD.70    
      IF(SCALE.LT.ABS(FMIN))SCALE=ABS(FMIN)                                OUTFLD.71    
      PRINT*,LTITLE(IOUT)                                                  OUTFLD.72    
      PRINT*,' MAX = ',FMAX,' MIN = ',FMIN                                 OUTFLD.73    
      IF(SCALE.EQ.0.)THEN                                                  OUTFLD.74    
      PRINT*,' '                                                           OUTFLD.75    
      PRINT*,' ALL VALUES ZERO '                                           OUTFLD.76    
      PRINT*,' '                                                           OUTFLD.77    
      ELSE                                                                 OUTFLD.78    
      II=NINT(ALOG10(SCALE))                                               OUTFLD.79    
      SCALE=10.**(-II+2)                                                   OUTFLD.80    
      PRINT*,' ALL FIELDS MULTIPLIED BY ',SCALE                            OUTFLD.81    
        INLAT=JG/NLAT                                                      OUTFLD.82    
        INLONG=MG/NLONG                                                    OUTFLD.83    
        DO 30 IHEM=1,NHEM                                                  OUTFLD.84    
        DO 30 JH=1,JG,INLAT                                                OUTFLD.85    
        SMEAN=SSUM(MG,GPR(1,JH,IHEM),1)*RMG                                OUTFLD.86    
        JJ=(2-IHEM)*JH + (IHEM-1)*(JG+1-JH)                                OUTFLD.87    
30      PRINT 1000,(3-2*IHEM)*ALAT(JJ),                                    OUTFLD.88    
     :                   (NINT(SCALE*GPR(I,JH,IHEM)),I=1,MG,INLONG),       OUTFLD.89    
     :                    NINT(SCALE*SMEAN)                                OUTFLD.90    
      ENDIF                                                                OUTFLD.91    
      ENDIF                                                                OUTFLD.92    
C                                                                          OUTFLD.93    
50    CONTINUE                                                             OUTFLD.94    
1000  FORMAT(1X,F4.0,2X,18I4)                                              OUTFLD.95    
      RETURN                                                               OUTFLD.96    
      END                                                                  OUTFLD.97    
*DECK PREP                                                                 PREP.1     
      SUBROUTINE PREP(GPR,ITYPE)                                           PREP.2     
C                                                                          PREP.3     
C     ROUTINE PREPARES OUTPUT FOR PRINTING AND PLOTTING                    PREP.4     
C                                                                          PREP.5     
C                                                                          PREP.6     
*CALL PARAM1                                                               PREP.7     
*CALL PARAM2                                                               PREP.8     
*CALL GRIDP                                                                PREP.9     
*CALL LEGAU                                                                PREP.10    
*CALL BLANK                                                                PREP.11    
*CALL SPECTR                                                               PREP.12    
*CALL COMFFT                                                               PREP.13    
      REAL GPR(MG,JG,NHEM)                                                 PREP.14    
C                                                                          PREP.15    
C     (1) OROGRAPHY,  (2)  D/DX (GS)    (3)   D/DY(GS)                     PREP.16    
C     (4) UCHI,   (5)  VCHI,   (6)  DG,    (7)  ZG  ,  (8)  UPSI           PREP.17    
C     (9) VPSI    (10)  STREAM FUNCTION, (11) VORTICITY TENDENCY           PREP.18    
C     (12)  ROSSBY WAVE SOURCE                                             PREP.19    
C     (13) OROGRAPHICALLY FORCED DIVEREGNCE                                BUGSV.91    
C     (14) SPURIOUS OROGR. FORCING                                         BUGSV.92    
C                                                                          PREP.20    
      Z(1)=Z(1)-EZ                                                         PREP.21    
C                                                                          PREP.22    
C     SPECIAL CALCULATION FOR ROSSBY WAVE SOURCE                           PREP.23    
C                                                                          PREP.24    
      IF(ITYPE.EQ.12)THEN                                                  PREP.25    
        DO 160 I=1,IGA                                                     PREP.26    
160     ZROSS(I)=0.                                                        PREP.27    
        JL=1                                                               PREP.28    
        DO 150 JH=1,JG                                                     PREP.29    
        IF(JGL.EQ.1) THEN                                                  BUGS2.28    
          READ(25)ALP,DALP,RLP,RDLP                                        BUGS2.29    
          READ(27)UCHI,VCHI                                                BUGS2.30    
        ENDIF                                                              BUGS2.31    
        READ(28)ZG                                                         PREP.30    
        RCSJ=1./CS(JH)                                                     PREP.31    
        DO 110 IHEM=1,NHEM                                                 PREP.32    
        IOFF=(IHEM-1)*MGPP                                                 PREP.33    
        DO 120 I=1,MG                                                      PREP.34    
        J=I+IOFF                                                           PREP.35    
        UZG(J)=-RCSJ*ZG(J)*UCHI(J,JL)                                      PREP.36    
        VZG(J)=-ZG(J)*VCHI(J,JL)                                           PREP.37    
120     CONTINUE                                                           PREP.38    
110     CONTINUE                                                           PREP.39    
        CALL FFT991(UZG,WORK,TRIG,IFAX,1,MGPP,MG,2*NHEM,-1)                PREP.40    
        CALL EIM(UZG,UZG,1)                                                PREP.41    
        CALL HANAL(UZG,ZROSS,1,1)                                          PREP.42    
        CALL HANAL(VZG,ZROSS,1,3)                                          PREP.43    
150     JL=JL+JINC                                                         PREP.44    
        IF(JGL.EQ.1) THEN                                                  BUGS2.32    
          REWIND 25                                                        BUGS2.33    
          REWIND 27                                                        BUGS2.34    
        ENDIF                                                              BUGS2.35    
        REWIND 28                                                          PREP.45    
      ENDIF                                                                PREP.46    
C                                                                          PREP.47    
C     NOW FOR GENERAL LOOP OVER LATITUDE, PICKING UP  CORRECT DATA         PREP.48    
C         AND PUTTING IT INTO ZG ARRAY                                     PREP.49    
C                                                                          PREP.50    
      JL=1                                                                 PREP.51    
      DO 20 JH=1,JG                                                        PREP.52    
      IF(ITYPE.EQ.1)THEN                                                   PREP.53    
        IF(JGL.EQ.1)THEN                                                   PREP.54    
        READ(26)ZG                                                         PREP.55    
        ELSE                                                               PREP.56    
        DO 70 I=1,IGC                                                      PREP.57    
70      ZG(I)=GSG(I,JL)                                                    PREP.58    
        ENDIF                                                              PREP.59    
      ELSEIF(ITYPE.EQ.2)THEN                                               PREP.60    
        IF(JGL.EQ.1)THEN                                                   PREP.61    
        READ(26)ZG,ZG                                                      PREP.62    
        ELSE                                                               PREP.63    
        DO 71 I=1,IGC                                                      PREP.64    
71      ZG(I)=GSX(I,JL)                                                    PREP.65    
        ENDIF                                                              PREP.66    
      ELSEIF(ITYPE.EQ.3)THEN                                               PREP.67    
        IF(JGL.EQ.1)THEN                                                   PREP.68    
        READ(26)ZG,ZG,ZG                                                   PREP.69    
        ELSE                                                               PREP.70    
        DO 72 I=1,IGC                                                      PREP.71    
72      ZG(I)=GSY(I,JL)                                                    PREP.72    
        ENDIF                                                              PREP.73    
      ELSEIF(ITYPE.EQ.4)THEN                                               PREP.74    
        IF(JGL.EQ.1)THEN                                                   PREP.75    
        READ(27)ZG                                                         PREP.76    
        ELSE                                                               PREP.77    
        DO 73 I=1,IGC                                                      PREP.78    
73      ZG(I)=UCHI(I,JL)                                                   PREP.79    
        ENDIF                                                              PREP.80    
      ELSEIF(ITYPE.EQ.5)THEN                                               PREP.81    
        IF(JGL.EQ.1)THEN                                                   PREP.82    
        READ(27)ZG,ZG                                                      PREP.83    
        ELSE                                                               PREP.84    
        DO 74 I=1,IGC                                                      PREP.85    
74      ZG(I)=VCHI(I,JL)                                                   PREP.86    
        ENDIF                                                              PREP.87    
      ELSEIF(ITYPE.EQ.6)THEN                                               PREP.88    
        IF(JGL.EQ.1)THEN                                                   PREP.89    
        READ(27)ZG,ZG,ZG                                                   PREP.90    
        ELSE                                                               PREP.91    
        DO 75 I=1,IGC                                                      PREP.92    
75      ZG(I)=DG(I,JL)                                                     PREP.93    
        ENDIF                                                              PREP.94    
      ELSEIF(ITYPE.EQ.7)THEN                                               PREP.95    
        READ(28)ZG                                                         PREP.96    
      ELSEIF(ITYPE.EQ.8)THEN                                               PREP.97    
        READ(28)ZG,ZG                                                      PREP.98    
      ELSEIF(ITYPE.EQ.9)THEN                                               PREP.99    
        READ(28)ZG,ZG,ZG                                                   PREP.100   
      ELSEIF(ITYPE.EQ.10)THEN                                              PREP.101   
        IF(JGL.EQ.1) READ(25)ALP,DALP,RLP,RDLP                             BUGS2.36    
        CALL HEXP(Z,ZG,1,5)                                                PREP.102   
        CALL FFT991(ZG,WORK,TRIG,IFAX,1,MGPP,MG,NHEM,1)                    PREP.103   
      ELSEIF(ITYPE.EQ.11)THEN                                              PREP.104   
        IF(JGL.EQ.1) READ(25)ALP,DALP,RLP,RDLP                             BUGS2.37    
        CALL HEXP(ZT,ZG,1,1)                                               PREP.105   
        CALL FFT991(ZG,WORK,TRIG,IFAX,1,MGPP,MG,NHEM,1)                    PREP.106   
      ELSEIF(ITYPE.EQ.12)THEN                                              PREP.107   
        IF(JGL.EQ.1) READ(25)ALP,DALP,RLP,RDLP                             BUGS2.38    
        CALL HEXP(ZROSS,ZG,1,1)                                            PREP.108   
        CALL FFT991(ZG,WORK,TRIG,IFAX,1,MGPP,MG,NHEM,1)                    PREP.109   
      ELSEIF(ITYPE.EQ.13)THEN                                              BUGSV.93    
      IF(JGL.EQ.1)READ(26)GSG,GSX,GSY                                      BUGS2.40    
      READ(28)ZG,UPSI,VPSI                                                 BUGSV.95    
      DO 76 I=1,IGC                                                        BUGSV.96    
76    ZG(I)=(UPSI(I)*GSX(I,JL)+VPSI(I)*GSY(I,JL))*HGT                      BUGSV.97    
      DO 760 IHEM=1,NHEM                                                   BUGSV.98    
      SIL=2.*(3-2*IHEM)*SI(JH)                                             BUGSV.99    
      DO 760 I=1+(IHEM-1)*MGPP,IHEM*MGPP                                   BUGSV.100   
760   ZG(I)=SIL*ZG(I)                                                      BUGSV.101   
      ELSEIF(ITYPE.EQ.14)THEN                                              BUGSV.102   
      IF(JGL.EQ.1)READ(26)GSG                                              BUGSV.103   
      READ(28)ZG,UPSI,VPSI                                                 BUGSV.104   
      DO 78 I=1,IGC                                                        BUGSV.105   
78    ZG(I)=2.*(VPSI(I)*GSG(I,JL))*HGT                                     BUGSV.106   
        ELSE                                                               PREP.110   
        PRINT*,' OPTION  NOT AVAILABLE '                                   PREP.111   
        CALL ABORT                                                         PREP.112   
        ENDIF                                                              PREP.113   
C                                                                          PREP.114   
C     NOW COPY ZG TO GPR WITH SUITABLE DIMENSIONALITY                      PREP.115   
C                                                                          PREP.116   
      DO 10 IHEM=1,NHEM                                                    PREP.117   
      IOFF=(IHEM-1)*MGPP                                                   PREP.118   
      JJ=(2-IHEM)*JH + (IHEM-1)*(JG+1-JH)                                  PREP.119   
      IF(ITYPE.EQ.4.OR.ITYPE.EQ.5.OR.ITYPE.EQ.8.OR.ITYPE.EQ.9)THEN         PREP.120   
        DO 11 I=1,MG                                                       PREP.121   
11      GPR(I,JJ,IHEM)=ZG(I+IOFF)*CV/SQRT(CS(JH))                          PREP.122   
      ELSEIF(ITYPE.EQ.1)THEN                                               PREP.123   
        DO 12 I=1,MG                                                       PREP.124   
12      GPR(I,JJ,IHEM)=ZG(I+IOFF)*CV*CV/GA                                 PREP.125   
      ELSEIF(ITYPE.EQ.2.OR.ITYPE.EQ.3)THEN                                 PREP.126   
        DO 13 I=1,MG                                                       PREP.127   
13      GPR(I,JJ,IHEM)=ZG(I+IOFF)*CV*CV/GA/RADEA                           PREP.128   
      ELSEIF(ITYPE.EQ.6)THEN                                               PREP.129   
        DO 14 I=1,MG                                                       PREP.130   
14      GPR(I,JJ,IHEM)=ZG(I+IOFF)*WW                                       PREP.131   
      ELSEIF(ITYPE.EQ.7)THEN                                               PREP.132   
        DO 15 I=1,MG                                                       PREP.133   
15      GPR(I,JJ,IHEM)=ZG(I+IOFF)*WW -2.*(3.-2.*IHEM)*SI(JH)*WW            PREP.134   
      ELSEIF(ITYPE.EQ.10)THEN                                              PREP.135   
        DO 16 I=1,MG                                                       PREP.136   
16      GPR(I,JJ,IHEM)=ZG(I+IOFF)*WW*RADEA*RADEA                           PREP.137   
      ELSEIF(ITYPE.EQ.11)THEN                                              PREP.138   
        DO 17 I=1,MG                                                       PREP.139   
17      GPR(I,JJ,IHEM)=ZG(I+IOFF)*WW*WW*86400.                             PREP.140   
      ELSEIF(ITYPE.EQ.12)THEN                                              PREP.141   
        DO 18 I=1,MG                                                       PREP.142   
18      GPR(I,JJ,IHEM)=ZG(I+IOFF)*WW*WW*1.E11                              PREP.143   
      ELSEIF(ITYPE.EQ.13)THEN                                              BUGSV.107   
      DO 19 I=1,MG                                                         BUGSV.108   
19    GPR(I,JJ,IHEM)=ZG(I+IOFF)                                            BUGSV.109   
      ELSEIF(ITYPE.EQ.14)THEN                                              BUGSV.110   
      DO 21 I=1,MG                                                         BUGSV.111   
21    GPR(I,JJ,IHEM)=ZG(I+IOFF)                                            BUGSV.112   
      ENDIF                                                                PREP.144   
10    CONTINUE                                                             PREP.145   
20    JL=JL+JINC                                                           PREP.146   
C                                                                          PREP.147   
C     FINALLY REWIND OUTPUT CHANNELS IF THEY HAVE BEEN USED                PREP.148   
C                                                                          PREP.149   
      REWIND 25                                                            BUGS2.39    
      REWIND 26                                                            BUGSV.113   
      REWIND 27                                                            BUGSV.114   
      REWIND 28                                                            BUGSV.115   
      Z(1)=Z(1)+EZ                                                         PREP.161   
      RETURN                                                               PREP.162   
      END                                                                  PREP.163   
*DECK FORCE                                                                FORCE.1     
      SUBROUTINE FORCE(GS,ECC,WN,COLAT,CENTRE,DIM)                         FORCE.2     
C                                                                          FORCE.3     
C     CALCULATES HOSKINS AND KAROLY BLOB                                   FORCE.4     
C                                                                          FORCE.5     
*CALL PARAM1                                                               FORCE.6     
*CALL PARAM2                                                               FORCE.7     
*CALL LEGAU                                                                FORCE.8     
      REAL GS(IGC)                                                         FORCE.9     
      DO 1 I=1,IGC                                                         FORCE.10    
    1 GS(I)=0.                                                             FORCE.11    
      AKI=PI*COLAT/180.                                                    FORCE.12    
      CEN=PI*CENTRE/180.                                                   FORCE.13    
      SKI=SIN(AKI)                                                         FORCE.14    
      CKI=COS(AKI)                                                         FORCE.15    
      WNH=WN/2.                                                            FORCE.16    
      PIH=PI/2.                                                            FORCE.17    
      DLAM=PI2/REAL(MG)                                                    FORCE.18    
      STH=SI(JH)                                                           FORCE.19    
      CTH=SQRT(CS(JH))                                                     FORCE.20    
      DO 14 IHEM=1,NHEM                                                    FORCE.21    
      II=(IHEM-1)*MGPP                                                     FORCE.22    
      STH=(3-2*IHEM)*STH                                                   FORCE.23    
      ALAM=-CEN-DLAM                                                       FORCE.24    
      DO 10 I=1,MG                                                         FORCE.25    
      II=II+1                                                              FORCE.26    
      ALAM=ALAM+DLAM                                                       FORCE.27    
      CLAM=COS(ALAM)                                                       FORCE.28    
      SLAM=SIN(ALAM)                                                       FORCE.29    
      XP=CTH*CLAM*CKI-STH*SKI                                              FORCE.30    
      YP=CTH*SLAM                                                          FORCE.31    
      ZP=CTH*CLAM*SKI+STH*CKI                                              FORCE.32    
      CTHP=SQRT(XP*XP/ECC+YP*YP*ECC)                                       FORCE.33    
      THP=0.                                                               FORCE.34    
      IF(CTHP.LT.1.)THP=ACOS(CTHP)                                         FORCE.35    
      SP=WNH*(PIH-THP)                                                     FORCE.36    
      IF(ZP.LT.0.)SP=PI                                                    FORCE.37    
      GS(II)=DIM*COS(SP)*COS(SP)                                           FORCE.38    
      IF(SP.GT.PIH)GS(II)=0.                                               FORCE.39    
  10  CONTINUE                                                             FORCE.40    
  14  CONTINUE                                                             FORCE.41    
      RETURN                                                               FORCE.42    
      END                                                                  FORCE.43    
      SUBROUTINE GWTLT(SIT,WEIGHT,J,JG)                                    FORCE.44    
C                                                                          FORCE.45    
C     NORMALLY A ROUTINE IN SUBLIB BUT INCLUDED HERE FOR PORTABLITY        FORCE.46    
C                                                                          FORCE.47    
      PARAMETER(PI=3.14159265359)                                          FORCE.48    
      DOUBLE PRECISION ACC,SA,SB,SC,D1,D2,D4,BN,GG,X,AMM,AMN,              FORCE.49    
     1 EM,ANN,RE,A,DD,DLT,DTH                                              FORCE.50    
      ACC=1.0D-23                                                          FORCE.51    
      SA=DSQRT(.5D0)                                                       FORCE.52    
      SB=DSQRT(1.5D0)                                                      FORCE.53    
      SC=DSQRT(1.D0/3.D0)                                                  FORCE.54    
      D1=1.D0                                                              FORCE.55    
      D2=2.D0                                                              FORCE.56    
      D4=4.D0                                                              FORCE.57    
      NNN=JG+JG                                                            FORCE.58    
      BN=NNN                                                               FORCE.59    
      GG=D2*BN+D1                                                          FORCE.60    
      HH=8.*BN*BN                                                          FORCE.61    
      K=0                                                                  FORCE.62    
      AJ=J                                                                 FORCE.63    
      TH=PI*(2.*AJ-.5)/GG                                                  FORCE.64    
      DTH=TH+(COS(TH)/SIN(TH))/HH                                          FORCE.65    
      X=DCOS(DTH)                                                          FORCE.66    
54    CONTINUE                                                             FORCE.67    
      AMM=SA                                                               FORCE.68    
      AMN=X*SB                                                             FORCE.69    
      EM=SC                                                                FORCE.70    
      ANN=D1                                                               FORCE.71    
      DO 51 N=2,NNN                                                        FORCE.72    
      ANN=ANN+D1                                                           FORCE.73    
      RE=DSQRT(D4*ANN*ANN-D1)/ANN                                          FORCE.74    
      A=RE*(X*AMN-EM*AMM)                                                  FORCE.75    
      AMM=AMN                                                              FORCE.76    
      AMN=A                                                                FORCE.77    
      EM=D1/RE                                                             FORCE.78    
51    CONTINUE                                                             FORCE.79    
      DD=GG*EM*AMM-X*ANN*A                                                 FORCE.80    
      K=K+1                                                                FORCE.81    
      DLT=(D1-X*X)*A/DD                                                    FORCE.82    
      IF (DABS(DLT).LT.ACC) GOTO 52                                        FORCE.83    
      IF (K.GT.50) GOTO 53                                                 FORCE.84    
      X=X-DLT                                                              FORCE.85    
      GOTO 54                                                              FORCE.86    
53    CONTINUE                                                             FORCE.87    
      WRITE (2,105)                                                        FORCE.88    
105   FORMAT(15H NO CONVERGENCE)                                           FORCE.89    
52    CONTINUE                                                             FORCE.90    
      WEIGHT=GG*(D1-X*X)/(DD*DD)                                           FORCE.91    
      SIT=X                                                                FORCE.92    
      RETURN                                                               FORCE.93    
      END                                                                  FORCE.94    
*DECK EIM                                                                  EIM.1     
      SUBROUTINE EIM(SVIN,SVOUT,NLS)                                       EIM.2     
C                                                                          EIM.3     
C     PERFORMS D/DLONGITUDE ON HALF TRANSFORMS                             EIM.4     
C                                                                          EIM.5     
*CALL PARAM1                                                               EIM.6     
*CALL PARAM2                                                               EIM.7     
*CALL POLYNO                                                               EIM.8     
      COMPLEX SVIN(IGL*NLS),SVOUT(IGL*NLS)                                 EIM.9     
      DO 10 L=1,NLS                                                        EIM.10    
      II=(L-1)*IGL                                                         EIM.11    
      DO 10 I=1,IGL                                                        EIM.12    
      II=II+1                                                              EIM.13    
      SVOUT(II)=CMPA(I)*SVIN(II)                                           EIM.14    
10    CONTINUE                                                             EIM.15    
      RETURN                                                               EIM.16    
      END                                                                  EIM.17    
*DECK ENERGY                                                               ENERGY.1     
      SUBROUTINE ENERGY                                                    ENERGY.2     
*CALL PARAM1                                                               ENERGY.3     
*CALL PARAM2                                                               ENERGY.4     
*CALL SPECTR                                                               ENERGY.5     
*CALL BLANK                                                                ENERGY.6     
      IF(KOUNTO.NE.0)THEN                                                  ENERGY.7     
      ITSPD=NINT(TSPD)                                                     ENERGY.8     
      IF(KOUNT.EQ.0.OR.                                                    ENERGY.9     
     : (KITS.EQ.0.AND.(KOUNT/ITSPD)*ITSPD.EQ.KOUNT).OR.                    ENERGY.10    
     : (KITS.NE.0.AND.KOUNT.GT.KITS-1.AND.                                 ENERGY.11    
     : ((KOUNT+KITS-1)/ITSPD)*ITSPD.EQ.(KOUNT+KITS-1)))THEN                ENERGY.12    
      Z(1)=Z(1)-EZ                                                         ENERGY.13    
      PSITOT=0.                                                            ENERGY.14    
      PPITOT=0.                                                            ENERGY.15    
      DO 800 IHEM=1,NHEM                                                   ENERGY.16    
      IG=(IHEM-1)*NWJ2                                                     ENERGY.17    
      DO 10 JP=1,NN,2                                                      ENERGY.18    
      IG=IG+1                                                              ENERGY.19    
10    PSITOT=PSITOT+0.5*REAL(Z(IG))*REAL(Z(IG))                            ENERGY.20    
      DO 20 MP=MOCT+1,MM,MOCT                                              BUGS2.1     
      DO 20 IN=MP,NN,2                                                     ENERGY.22    
      IG=IG+1                                                              ENERGY.23    
      PPITOT=PPITOT+REAL(Z(IG)*CONJG(Z(IG)))                               ENERGY.24    
20    CONTINUE                                                             ENERGY.25    
800   CONTINUE                                                             ENERGY.26    
      WRITE(6,100)KOUNT,PSITOT,PPITOT                                      ENERGY.27    
100   FORMAT(1X,' MEAN AND PERT RMS VORT AT KOUNT= ',I6,                   ENERGY.28    
     : 1X,2E15.6)                                                          ENERGY.29    
      Z(1)=Z(1)+EZ                                                         ENERGY.30    
      ENDIF                                                                ENERGY.31    
      ENDIF                                                                ENERGY.32    
      RETURN                                                               ENERGY.33    
      END                                                                  ENERGY.34    
*DECK INIUTF                                                               INIUTF.1     
      SUBROUTINE INIUTF(NAME,NCHAN)                                        INIUTF.2     
C                                                                          INIUTF.3     
C     UGAMP Transfer File, Version 1.3.                                    INIUTF.4     
C     Initialise common block values and write global header.              INIUTF.5     
C                                                                          INIUTF.6     
*CALL PARAM1                                                               INIUTF.7     
*CALL PARAM2                                                               INIUTF.8     
*CALL BLANK                                                                INIUTF.9     
      PARAMETER(IALEN=(MG+1)*JGG)                                          INIUTF.10    
C                                                                          INIUTF.11    
      COMMON/CMCUTF/ASCARR(2,IALEN)                                        INIUTF.12    
     :,LHDR,LDAT,LEND,LHT1,LHT2,LFT1,LFT2D,LFT2T                           INIUTF.13    
      CHARACTER*1  ASCARR                                                  INIUTF.14    
      CHARACTER*21 LHDR,LDAT,LEND                                          INIUTF.15    
      CHARACTER*50 LHT1,LHT2,LFT1,LFT2D,LFT2T                              INIUTF.16    
C                                                                          INIUTF.17    
      CHARACTER NAME*(*)                                                   INIUTF.18    
      COMMON/CMIUTF/IHR1(15),IFR3(15)                                      INIUTF.19    
C                                                                          INIUTF.20    
      REAL ALONR(MG),ALATR(JGG)                                            INIUTF.21    
C                                                                          INIUTF.22    
C                                                                          INIUTF.23    
C     Set up data for global header.                                       INIUTF.24    
C                                                                          INIUTF.25    
      LHDR='***START OF HEADER***'                                         INIUTF.26    
      LDAT='***START OF DATA***  '                                         INIUTF.27    
      LEND='***END OF DATA***    '                                         INIUTF.28    
C                                                                          INIUTF.29    
      JTYP=2                                                               INIUTF.30    
      NL=1                                                                 INIUTF.31    
C                                                                          INIUTF.32    
      DO 10 I=1,15                                                         INIUTF.33    
   10 IHR1(I)=0                                                            INIUTF.34    
      IHR1(1)=MG                                                           INIUTF.35    
      IHR1(2)=JG                                                           INIUTF.36    
      IHR1(3)=NL                                                           INIUTF.37    
      IHR1(4)=NHEM                                                         INIUTF.38    
      IHR1(5)=MOCT                                                         INIUTF.39    
      IHR1(6)=JTYP                                                         INIUTF.40    
      IHR1(8)=MM                                                           INIUTF.41    
      IHR1(9)=NN                                                           INIUTF.42    
      IHR1(10)=NWJ2                                                        INIUTF.43    
C                                                                          INIUTF.44    
C                                                                          INIUTF.45    
C                                                                          INIUTF.46    
      IF(KITS.EQ.0)THEN                                                    INIUTF.47    
        BEGDAY=0.0                                                         INIUTF.48    
        ENDDAY=KTOTAL/TSPD                                                 INIUTF.49    
      ELSE                                                                 INIUTF.50    
        BEGDAY=0.0                                                         INIUTF.51    
        ENDDAY=(KTOTAL+KITS-1)/TSPD                                        INIUTF.52    
      ENDIF                                                                INIUTF.53    
C                                                                          INIUTF.54    
      DLONG=360./(MG*MOCT)                                                 INIUTF.55    
      DO 20 I=1,MG                                                         INIUTF.56    
20    ALONR(I)=(I-1)*DLONG                                                 INIUTF.57    
      DO 30 J=1,JG                                                         INIUTF.58    
      ALATR(J)=ALAT(J)                                                     INIUTF.59    
      IF(NHEM.EQ.2)ALATR(JGG+1-J)=-ALAT(J)                                 INIUTF.60    
30    CONTINUE                                                             INIUTF.61    
      SIGMA=1000.                                                          INIUTF.62    
C                                                                          INIUTF.63    
C     Write global header.                                                 INIUTF.64    
C                                                                          INIUTF.65    
      WRITE(NCHAN,'(A21,29X,''.'')') LHDR                                  INIUTF.66    
      WRITE(NCHAN,'(15I5)') (IHR1(I),I=1,15)                               INIUTF.67    
      WRITE(NCHAN,'((10F7.2))') (ALONR(I),I=1,MG)                          INIUTF.68    
      WRITE(NCHAN,'((10F7.2))') (ALATR(J),J=1,JGG)                         INIUTF.69    
      WRITE(NCHAN,'((10F7.1))') SIGMA                                      INIUTF.70    
      WRITE(LHT1,'(''RUN '',F8.3,5X,''DAYS '',F10.2,'' TO'',F10.2,5X)')    INIUTF.71    
     :      RNTAPE,BEGDAY,ENDDAY                                           INIUTF.72    
      LHT1='                                                   '           INIUTF.73    
      WRITE(LHT2,'(50X)')                                                  INIUTF.74    
      DO 50 I=1,LEN(NAME)                                                  INIUTF.75    
50    LHT2(I:I)=NAME(I:I)                                                  INIUTF.76    
      WRITE(NCHAN,'(A50,''.'')') LHT1                                      INIUTF.77    
      WRITE(NCHAN,'(A50,''.'')') LHT2                                      INIUTF.78    
      WRITE(NCHAN,'(A21,29X,''.'')') LDAT                                  INIUTF.79    
C                                                                          INIUTF.80    
C     Initialise field header arrays.                                      INIUTF.81    
C                                                                          INIUTF.82    
      WRITE(LFT1,'(50X)')                                                  INIUTF.83    
      WRITE(LFT2D,'(''RUN '',F8.3,3X,''DAY'',32X)') RNTAPE                 INIUTF.84    
      WRITE(LFT2T,'(''RUN '',F8.3,3X,''DAY'',F10.2,'' TO'',F10.2           INIUTF.85    
     :              ,'' AVERAGE '')') RNTAPE,BEGDAY,ENDDAY                 INIUTF.86    
      DO 40 I=1,15                                                         INIUTF.87    
   40 IFR3(I)=0                                                            INIUTF.88    
C                                                                          INIUTF.89    
C     Initialise character look-up table for ASCOUT.                       INIUTF.90    
C                                                                          INIUTF.91    
      CALL ASCSEN                                                          INIUTF.92    
C                                                                          INIUTF.93    
      RETURN                                                               INIUTF.94    
      END                                                                  INIUTF.95    
*DECK ENDUTF                                                               ENDUTF.1     
      SUBROUTINE ENDUTF(NCHAN)                                             ENDUTF.2     
C                                                                          ENDUTF.3     
C     UGAMP Transfer File, Version 1.3.                                    ENDUTF.4     
C     Write end of data record.                                            ENDUTF.5     
C                                                                          ENDUTF.6     
*CALL PARAM1                                                               ENDUTF.7     
*CALL PARAM2                                                               ENDUTF.8     
      PARAMETER(IALEN=(MG+1)*JGG)                                          ENDUTF.9     
C                                                                          ENDUTF.10    
      COMMON/CMCUTF/ASCARR(2,IALEN)                                        ENDUTF.11    
     :,LHDR,LDAT,LEND,LHT1,LHT2,LFT1,LFT2D,LFT2T                           ENDUTF.12    
      CHARACTER*1  ASCARR                                                  ENDUTF.13    
      CHARACTER*21 LHDR,LDAT,LEND                                          ENDUTF.14    
      CHARACTER*50 LHT1,LHT2,LFT1,LFT2D,LFT2T                              ENDUTF.15    
C                                                                          ENDUTF.16    
      COMMON/CMIUTF/IHR1(15),IFR3(15)                                      ENDUTF.17    
C                                                                          ENDUTF.18    
      WRITE(NCHAN,'(A21,29X,''.'')') LEND                                  ENDUTF.19    
C                                                                          ENDUTF.20    
      RETURN                                                               ENDUTF.21    
      END                                                                  ENDUTF.22    
*DECK WTFUTF                                                               WTFUTF.1     
      SUBROUTINE WTFUTF(G,IX,IY,IPTYP,ICSTYL,IFDTYP,ILVTYP,IFRAME,IMSK     WTFUTF.2     
     :                 ,FMIN,FMAX,GINC,DAY,NAME,NCHAN,IFAIL)               WTFUTF.3     
C                                                                          WTFUTF.4     
C     UGAMP Transfer File, Version 1.3.                                    WTFUTF.5     
C     Routine to write a data field to the file.                           WTFUTF.6     
C                                                                          WTFUTF.7     
*CALL PARAM1                                                               WTFUTF.8     
*CALL PARAM2                                                               WTFUTF.9     
      PARAMETER(IALEN=(MG+1)*JGG)                                          WTFUTF.10    
C                                                                          WTFUTF.11    
      COMMON/CMCUTF/ASCARR(2,IALEN)                                        WTFUTF.12    
     :,LHDR,LDAT,LEND,LHT1,LHT2,LFT1,LFT2D,LFT2T                           WTFUTF.13    
      CHARACTER*1  ASCARR                                                  WTFUTF.14    
      CHARACTER*21 LHDR,LDAT,LEND                                          WTFUTF.15    
      CHARACTER*50 LHT1,LHT2,LFT1,LFT2D,LFT2T                              WTFUTF.16    
C                                                                          WTFUTF.17    
      COMMON/CMIUTF/IHR1(15),IFR3(15)                                      WTFUTF.18    
      REAL G(IX*IY)                                                        WTFUTF.19    
      CHARACTER NAME*(*)                                                   WTFUTF.20    
C                                                                          WTFUTF.21    
 2900 FORMAT(/' ***WTFUTF : ',A,' NOT DUMPED : LENGTH OF ASCARR',          WTFUTF.22    
     :      /' (IALEN) MUST BE INCREASED FROM',I5,' TO',I5)                WTFUTF.23    
 2910 FORMAT(/' ***WTFUTF : WARNING : ',A,/' HAS ZERO RANGE')              WTFUTF.24    
C                                                                          WTFUTF.25    
C     Check size of data array.                                            WTFUTF.26    
C                                                                          WTFUTF.27    
      NCHAR=LEN(NAME)                                                      WTFUTF.28    
      nchar=min(nchar,50)                                                  WTFUTF.29    
C                                                                          WTFUTF.30    
      NXY=IX*IY                                                            WTFUTF.31    
      IF (NXY.GT.IALEN) THEN                                               WTFUTF.32    
         PRINT 2900, NAME,IALEN,NXY                                        WTFUTF.33    
         IFAIL=1                                                           WTFUTF.34    
         RETURN                                                            WTFUTF.35    
      ENDIF                                                                WTFUTF.36    
C                                                                          WTFUTF.37    
C     Calculate minimum and maximum values of field if input values        WTFUTF.38    
C     are zero.                                                            WTFUTF.39    
C                                                                          WTFUTF.40    
      IF (FMIN.EQ.0..AND.FMAX.EQ.0.) THEN                                  WTFUTF.41    
         GMAX=G(1)                                                         WTFUTF.42    
         GMIN=G(1)                                                         WTFUTF.43    
         DO 100 I=2,NXY                                                    WTFUTF.44    
         IF(G(I).GT.GMAX)GMAX=G(I)                                         WTFUTF.45    
         IF(G(I).LT.GMIN)GMIN=G(I)                                         WTFUTF.46    
100      CONTINUE                                                          WTFUTF.47    
      ELSE                                                                 WTFUTF.48    
         GMIN=FMIN                                                         WTFUTF.49    
         GMAX=FMAX                                                         WTFUTF.50    
      ENDIF                                                                WTFUTF.51    
C                                                                          WTFUTF.52    
C     Check range of field.                                                WTFUTF.53    
C                                                                          WTFUTF.54    
      RANGE=GMAX-GMIN                                                      WTFUTF.55    
      GAMAX=AMAX1(ABS(GMIN),ABS(GMAX))                                     WTFUTF.56    
      IF (RANGE.LE.GAMAX*1.E-10) THEN                                      WTFUTF.57    
         PRINT 2910,NAME                                                   WTFUTF.58    
         IFAIL=2                                                           WTFUTF.59    
      ENDIF                                                                WTFUTF.60    
C                                                                          WTFUTF.61    
C     Set up integer switch record.                                        WTFUTF.62    
C                                                                          WTFUTF.63    
      IFR3(1)=IX                                                           WTFUTF.64    
      IFR3(2)=IY                                                           WTFUTF.65    
      IFR3(3)=IPTYP                                                        WTFUTF.66    
      IFR3(4)=ICSTYL                                                       WTFUTF.67    
      IFR3(5)=IFDTYP                                                       WTFUTF.68    
      IFR3(6)=ILVTYP                                                       WTFUTF.69    
      IFR3(7)=IFRAME                                                       WTFUTF.70    
      IFR3(9)=IMSK                                                         WTFUTF.71    
C                                                                          WTFUTF.72    
C     Write field header.                                                  WTFUTF.73    
C                                                                          WTFUTF.74    
      WRITE(LFT2D(30:39),'(F10.2)')DAY                                     WTFUTF.75    
      WRITE(NCHAN,'(A50,''.'')') NAME(1:nchar)                             WTFUTF.76    
      WRITE(NCHAN,'(A50,''.'')') LFT2D                                     WTFUTF.77    
      WRITE(NCHAN,'(15I5)') (IFR3(I),I=1,15)                               WTFUTF.78    
      WRITE(NCHAN,'(1P,3E15.7)') GMIN,GMAX,GINC                            WTFUTF.79    
C                                                                          WTFUTF.80    
C     Pack and write data.                                                 WTFUTF.81    
C                                                                          WTFUTF.82    
      CALL ASCOUN(G,NXY,ASCARR,GMIN,GMAX,NCHAN)                            WTFUTF.83    
      IFAIL=0                                                              WTFUTF.84    
C                                                                          WTFUTF.85    
      RETURN                                                               WTFUTF.86    
      END                                                                  WTFUTF.87    
*DECK ASCOUN                                                               ASCOUN.1     
      SUBROUTINE ASCOUN(ARRAY,NPTS,ASCARR,GMIN,GMAX,NCHAN)                 ASCOUN.2     
C                                                                          ASCOUN.3     
C     Pack and write a data array as a set of pairs of characters.         ASCOUN.4     
C     Uses the characters 0-9 and lower and upper case A-Z only.           ASCOUN.5     
C                                                                          ASCOUN.6     
C     Input arguments:                                                     ASCOUN.7     
C        ARRAY   -    Real data array.                                     ASCOUN.8     
C        NPTS    -    Dimension of array.                                  ASCOUN.9     
C        ASCARR  -    A CHARACTER*1 workspace array of length 2*NPTS.      ASCOUN.10    
C        GMIN    -    Minimum value of array.                              ASCOUN.11    
C        GMAX    -    Maximum value of array.                              ASCOUN.12    
C        NCHAN   -    Fortran channel for data output.                     ASCOUN.13    
C     Arguments unchanged on output except ASCARR contains characters.     ASCOUN.14    
C                                                                          ASCOUN.15    
C     Kevin Dunn / Mike Blackburn     U.G.A.M.P.   03.01.89.               ASCOUN.16    
C     Based on code by M. A. ROWE       (FRAM)        09.87.               ASCOUN.17    
C                                                                          ASCOUN.18    
      REAL ARRAY(NPTS)                                                     ASCOUN.19    
      CHARACTER*1  ASCARR(2,NPTS), LKUP(63)                                ASCOUN.20    
      LOGICAL LASCII                                                       ASCOUN.21    
      SAVE LKUP                                                            ASCOUN.22    
C                                                                          ASCOUN.23    
C     Find scaling factor. Set to unity for zero field range.              ASCOUN.24    
C                                                                          ASCOUN.25    
      GAMAX=AMAX1(ABS(GMAX),ABS(GMIN))                                     ASCOUN.26    
      RANGE=GMAX-GMIN                                                      ASCOUN.27    
      ARANG=62.*62.-1.                                                     ASCOUN.28    
      IF (RANGE.LE.GAMAX*1.E-10) THEN                                      ASCOUN.29    
         SCALE=0.                                                          ASCOUN.30    
      ELSE                                                                 ASCOUN.31    
         SCALE=ARANG/RANGE                                                 ASCOUN.32    
      ENDIF                                                                ASCOUN.33    
C                                                                          ASCOUN.34    
C     Scale data using range of field and encode each value                ASCOUN.35    
C     using subscript of look-up table character.                          ASCOUN.36    
C                                                                          ASCOUN.37    
      DO 10 N=1,NPTS                                                       ASCOUN.38    
      INTEG=NINT((ARRAY(N)-GMIN)*SCALE)                                    ASCOUN.39    
      ICODE1=1+INTEG/62                                                    ASCOUN.40    
      ICODE2=1+MOD(INTEG,62)                                               ASCOUN.41    
      ASCARR(1,N)=LKUP(ICODE1)                                             ASCOUN.42    
      ASCARR(2,N)=LKUP(ICODE2)                                             ASCOUN.43    
   10 CONTINUE                                                             ASCOUN.44    
C                                                                          ASCOUN.45    
C     Write encoded data.                                                  ASCOUN.46    
C                                                                          ASCOUN.47    
      WRITE(NCHAN,'(64A1)') ((ASCARR(I,N),I=1,2),N=1,NPTS)                 ASCOUN.48    
C                                                                          ASCOUN.49    
      RETURN                                                               ASCOUN.50    
C                                                                          ASCOUN.51    
C*******************                                                       ASCOUN.52    
      ENTRY ASCSEN                                                         ASCOUN.53    
C                                                                          ASCOUN.54    
C     Define look-up table of characters.                                  ASCOUN.55    
C     Table includes 0-9 and lower and upper case characters A-Z           ASCOUN.56    
C     but not control characters. ASCII or EBCDIC character sets           ASCOUN.57    
C     are allowed and test made to determine current set.                  ASCOUN.58    
C     Characters 1-62 in LKUP are used to represent integer values         ASCOUN.59    
C     1-62. The range of the data field is scaled to 62*62 and two         ASCOUN.60    
C     characters used to represent each datum (2 digits in base 62).       ASCOUN.61    
C     63rd character in LKUP is blank for possible future masking.         ASCOUN.62    
C                                                                          ASCOUN.63    
      LASCII=ICHAR('0').NE.240                                             ASCOUN.64    
      IF (LASCII) THEN                                                     ASCOUN.65    
C***  Implementation for ASCII characters.                                 ASCOUN.66    
      DO 21 I=1,10                                                         ASCOUN.67    
   21 LKUP(I)=CHAR(I+47)                                                   ASCOUN.68    
      DO 22 I=11,36                                                        ASCOUN.69    
   22 LKUP(I)=CHAR(I+54)                                                   ASCOUN.70    
      DO 23 I=37,62                                                        ASCOUN.71    
   23 LKUP(I)=CHAR(I+60)                                                   ASCOUN.72    
      LKUP(63)=CHAR(32)                                                    ASCOUN.73    
      ELSE                                                                 ASCOUN.74    
C***  Implementation for EBCDIC characters                                 ASCOUN.75    
      DO 31 I=1,10                                                         ASCOUN.76    
   31 LKUP(I)=CHAR(I+239)                                                  ASCOUN.77    
      DO 32 I=11,19                                                        ASCOUN.78    
   32 LKUP(I)=CHAR(I+182)                                                  ASCOUN.79    
      DO 33 I=20,28                                                        ASCOUN.80    
   33 LKUP(I)=CHAR(I+189)                                                  ASCOUN.81    
      DO 34 I=29,36                                                        ASCOUN.82    
   34 LKUP(I)=CHAR(I+197)                                                  ASCOUN.83    
      DO 35 I=37,45                                                        ASCOUN.84    
   35 LKUP(I)=CHAR(I+92)                                                   ASCOUN.85    
      DO 36 I=46,54                                                        ASCOUN.86    
   36 LKUP(I)=CHAR(I+99)                                                   ASCOUN.87    
      DO 37 I=55,62                                                        ASCOUN.88    
   37 LKUP(I)=CHAR(I+107)                                                  ASCOUN.89    
      LKUP(63)=CHAR(64)                                                    ASCOUN.90    
      END IF                                                               ASCOUN.91    
      RETURN                                                               ASCOUN.92    
C*******************                                                       ASCOUN.93    
C                                                                          ASCOUN.94    
      END                                                                  ASCOUN.95    
