*COMDECK PARAM1                                                            PARAM1.1     
      PARAMETER(MM=21,NN=21,NL=15,NHEM=1,MOCT=1,MG=64,JG=16,NWJ2=121       PARAM1.2     
     :,NCRAY=64,JGL=JG,NTHSF=5)                                            PARAM1.3     
      PARAMETER(NSG=12,NGP=NSG+2,NXD=28,NXDF=NXD+8,NTH=4,NPH=6,NXP=19      PARAM1.4     
     :,NPMAX4=1001,NPMAX5=1001,NPMAX9=1001,NTERM5=27)                      PARAM1.5     
*COMDECK PARAM2                                                            PARAM2.1     
      PARAMETER(MH=2,PI=3.14159265359,PI2=2.*PI                            PARAM2.2     
     :,JGM=JG-1,JGP=JG+1,JGG=JG*NHEM,JGGM=JGG-1,JGGM2=JGG-2,JGGP=JGG+1     PARAM2.3     
     :,MGP=MG+1,MGPP=MG+2,NLM=NL-1,NLP=NL+1,NL2=NL*NL,MJP=NWJ2+NWJ2        PARAM2.4     
     :,NNP=NN+1,NWW=1+(MM-1)/MOCT,NWP=1+MM/MOCT,MOCTP=MOCT+1               PARAM2.5     
     :,IDA=3*MG/2+1,IDD=MGPP*NL,IDF=NCRAY*MGP,IDG=JG*NL                    PARAM2.6     
     :,IDH=MGP*JGGP,IDL=MGPP/2,IDK=IDL*NL,IDM=NNP/2,IDN=IDM*NL             PARAM2.7     
     :,IGA=NWJ2*NHEM,IGB=IGA*NL,IGC=MGPP*NHEM,IGD=IDD*NHEM,IGG=IDG*NHEM    PARAM2.8     
     :,IGL=IDL*NHEM,IGK=IDK*NHEM,IGM=IDM*NHEM,IGN=IDN*NHEM                 PARAM2.9     
     :,NLWG=10*NL+3,IDTHSF=IGC*NTHSF,IDDZ=NXDF*IGG,IPPZ=NXP*IGG            PARAM2.10    
     :,ILS1=(5*NL+1)*IGA                                                   PADLEN.1     
     :,ILG2=IGD*JG, ILG6=IDTHSF*JG*NTH, ILG7=IGC*JG*2*NPH                  PADLEN.2     
     :,ILFA=(2*(ILG6/ILG7))/(1+ILG6/ILG7), ILGA=ILG6*ILFA+ILG7*(1-ILFA)    PADLEN.3     
     :,ILFB=(2*(ILG2/ILGA))/(1+ILG2/ILGA), ILGB=ILG2*ILFB+ILGA*(1-ILFB)    PADLEN.4     
     :,ILFC=(ILGB-ILS1+1)/(ILGB-ILS1), ISPAD=(ILGB-ILS1)*ILFC+2*(1-ILFC)   PADLEN.5     
     : )                                                                   PADLEN.6     
C                                                                          PARAM2.12    
*COMDECK BATS                                                              BATS.1     
      COMMON/BATS/ALAT(JGG),AQ(NL2),G(NL2),TAU(NL2),RGG(NL2)               BATS.2     
     :,KOUNT,KSTART,KEND,KITS,KONTM,KHDAY,DAY                              BATS.3     
     :,DELT,DELT2,FTAV,NRTAV,LTAV,LSSD,LDRY                                BATS.4     
      LOGICAL LTAV,LSSD,LDRY                                               BATS.5     
C                                                                          BATS.6     
*COMDECK BLANK                                                             BLANK.1     
      COMMON/BLANK/ SQ(NNP),RSQ(NNP),SIGMAH(NLM),SIGMA(NL),SIGM1K(NL)      BLANK.2     
     :,SIGMAK(NL),T01S2(NLM),TMEAN(NL),ALPHA(NL),DSIGMA(NL),RDSIG(NL)      BLANK.3     
     :,TKP(NL),C(NL2),DRAG(NL),RNWN(NN)                                    BLANK.4     
     :,TSPD,GA,WW,RADEA,P0,EZ,AKAP,RD,RV,CPD,CLATNT                        BLANK.5     
     :,CPHASE,CV,CG,CT,CQ,CTT,CMBHR,CEP,CERT                               BLANK.6     
     :,DAMP,AKK,NDEL,NDELH,NDELHM                                          BLANK.7     
     :,MF,MFP,NF,NFP,MFPP,NFPP,RMG                                         BLANK.8     
      COMPLEX EZ,AIOCT                                                     BLANK.9     
C                                                                          BLANK.10    
*COMDECK COMFFT                                                            COMFFT.1     
      COMMON/COMFFT/NTWG,NRSTWG,NTNL,NRSTNL,TRIG(IDA),WORK(IDF),IFAX(10)   COMFFT.2     
C                                                                          COMFFT.3     
*COMDECK COMGEN                                                            COMGEN.1     
      COMMON/COMGEN/NPTS5,TIGZ(NL),TIGE(NL),TIDZ(NL),TIDE(NL)              COMGEN.2     
     :,TRNS(NL),TRNZ(NL),TRKZ(NL),TDRZ(NL),TDRE(NL)                        COMGEN.3     
     :,WMN(NL),TMN(NL),HMN(NL),WMNN,TMNN,HMNN                              COMGEN.4     
     :,TNS,TNZ,TNE,TKZ,TKE,TGS,TGZ,TGE,TDZ,TDE                             COMGEN.5     
     :,TCNZE,TCKZE,TCZZ,TCEE,TCSZ,TCSE,TCNSZ,TCNSE                         COMGEN.6     
     :,FIGZ,FIGE,FIDZ,FIDE,FRNS,FRNZ,FRKZ,FDRZ,FDRE                        COMGEN.7     
     :,SNS,SNZ,SNE,SKZ,SKE,SGS,SGZ,SGE,SDZ,SDE                             COMGEN.8     
     :,SCNZE,SCKZE,SCZZ,SCEE,SCSZ,SCSE,SCNSZ,SCNSE                         COMGEN.9     
     :,SIGZ,SIGE,SIDZ,SIDE,SRNS,SRNZ,SRKZ,SDRZ,SDRE                        COMGEN.10    
C                                                                          COMGEN.11    
*COMDECK COMGRM                                                            COMGRM.1     
      COMMON/COMGRM/DUDLSG(IGC,NL),DVDLSG(IGC,NL),DTDLSG(IGC,NL)           COMGRM.2     
     :,INTRL(IGC,NL)                                                       COMGRM.3     
C                                                                          COMGRM.4     
*COMDECK COMIOC                                                            COMIOC.1     
      COMMON/COMIOC/NCFICH,NCHIST,NCREST,NCSURF                            COMIOC.2     
     :,NCROGG,NCROGS,NCSTH,NCST4(2),NCPLOT(3)                              COMIOC.3     
     :,NCLEG,NCGEN,NCGDG,NCTHG,NCGP(NGP),NCDIM                             COMIOC.4     
     :,NLENTD,NLENHD,NLENWD                                                UCOS.1     
C                                                                          COMIOC.5     
      COMMON/COMIOL/LCHAN,LCHAN2                                           COMIOC.6     
     :,CPTHTD,CPTHHD,CPTHWD                                                UCOS.2     
     :,CBLANK                                                              UCOS.3     
      CHARACTER*8 LCHAN,LCHAN2                                             COMIOC.7     
      CHARACTER*80 CPTHTD,CPTHHD,CPTHWD                                    UCOS.4     
      CHARACTER*1 CBLANK                                                   UCOS.5     
C                                                                          COMIOC.8     
*COMDECK COMMSK                                                            COMMSK.1     
      COMMON/COMMSK/P3MSK(JGG,2)                                           DIMFILM.4     
     :,P2MIN,PMFAC,LMSK2,LMSK3,IMSK                                        COMMSK.3     
      LOGICAL LMSK2,LMSK3                                                  COMMSK.4     
C                                                                          COMMSK.5     
*COMDECK COMPRL                                                            COMPRL.1     
      COMMON/COMPRL/PSG(IGC,NL),PSRF(IGC),TSRF(IGC),OMSRF(IGC)             COMPRL.2     
     :,PSGMX(NL,NHEM),PSGMN(NL,NHEM)                                       COMPRL.3     
     :,LINTP2,LINTP3,NLPR,PPR(NL),PLOUT(NL)                                COMPRL.4     
     :,LXTRP2,LXTRP3,XLAPSE                                                COMPRL.5     
      LOGICAL LINTP2,LINTP3,LXTRP2,LXTRP3                                  COMPRL.6     
C                                                                          COMPRL.7     
*COMDECK COMROG                                                            COMROG.1     
      COMMON/COMROG/GSG(IGC,JGL),LROG,LROGGR,LROGPL,ROGFAC,ROGINC          COMROG.2     
      LOGICAL LROG,LROGGR,LROGPL                                           COMROG.3     
C                                                                          COMROG.4     
*COMDECK COMUTF                                                            COMUTF.1     
      PARAMETER(IALEN=321*161)                                             COMUTF.2     
C                                                                          COMUTF.3     
      COMMON/CMCUTF/ASCARR(2,IALEN)                                        COMUTF.4     
     :,LHDR,LDAT,LEND,LVER,LHT1,LHT2,LFT1,LFT2D,LFT2T                      COMUTF.5     
      CHARACTER*1  ASCARR                                                  COMUTF.6     
      CHARACTER*21 LHDR,LDAT,LEND,LVER                                     COMUTF.7     
      CHARACTER*50 LHT1,LHT2,LFT1,LFT2D,LFT2T                              COMUTF.8     
C                                                                          COMUTF.9     
      COMMON/CMIUTF/IHR1(15),IFR3(15)                                      COMUTF.10    
C                                                                          COMUTF.11    
*COMDECK DUM                                                               DUM.1     
      COMMON/DUM/GVE(IDH,3),GVZ(JGG,NL)                                    DUM.2     
C                                                                          DUM.3     
*COMDECK GRIDP                                                             GRIDP.1     
C     Array ordering in GRIDP and SPECTR must correspond.                  GRIDP.2     
C                                                                          GRIDP.3     
      COMMON/GRIDP/UG(IGD),VG(IGD),ZG(IGD),DG(IGD),QG(IGD),HG(IGD)         GRIDP.4     
     :,TG(IGD),PLG(IGC),TYG(IGD),PJG(IGC),TXG(IGD),PMG(IGC),SFG(IGD)       GRIDP.5     
     :,OMG(IGD),GHG(IGD),THG(IGD),EPVG(IGD),FUG(IGD),FVG(IGD),PMSLG(IGC)   GRIDP.6     
     :,UTHG(IDTHSF),VTHG(IDTHSF),ERTHG(IDTHSF),PTHG(IDTHSF)                GRIDP.7     
C                                                                          GRIDP.8     
*COMDECK INPB                                                              INPB.1     
      NAMELIST /INPB/ LSSD,RNTAPE,TSPD,KITS,TMEAN                          INPB.2     
     :,GA,RD,RV,AKAP,CLATNT,RADEA,WW,P0                                    INPB.3     
     :,TDISS,NDEL,RESTIM,DRAG                                              INPB.4     
     :,BEGDAY,ENDDAY,KOUNTD,KOUNTP,KOUNTF,KOUNTA,KOUNTE                    INPB.5     
     :,NPCA,NLAT,NLONG                                                     INPB.6     
     :,NPC1,NCOEFF,LSPO                                                    INPB.7     
     :,NPC2,LPC2,LSGEDY,LSGGRZ,LSGPLZ,LGPO,LGFO,LSGGR,LSGPL,SGFAC,SGINC    INPB.8     
     :,NPC3,LPC3,LXDGR,LXDPL,XDFAC,XDINC                                   INPB.9     
     :,NPC4,LSPPLT,ISPLIT                                                  INPB.10    
     :,NPC5,LPC5,LENCOP,ECONMX,ECONMN,ENRNGE,ENMN,XUEN,IYEN,IYCON          INPB.11    
     :,NPC6,LPC6,THSURD,CPHASE,LTHGR,LTHPL,THFAC,THINC                     INPB.12    
     :,NPC7,LPC7,LPHGR,LPHPL,PHFAC,PHINC                                   INPB.14    
     :,NPC8,LPC8,LXPGR,LXPPL,XPFAC,XPINC                                   INPB.15    
     :,NPC9,LPC9,LPHCOP                                                    INPB.16    
     :,LINTP2,LINTP3,LXTRP2,LXTRP3,NLPR,PLOUT                              INPB.17    
     :,LROG,LROGGR,LROGPL,ROGFAC,ROGINC,LMSK2,LMSK3                        INPB.18    
     :,NAME                                                                DIMFILM.2     
C                                                                          INPB.20    
*COMDECK INPHYS                                                            INPHYS.1     
      NAMELIST /INPHYS/ BEGDP,LDRY,LBL,LVD,LCR,LLR,LRD,CD,AKVV             INPHYS.2     
C                                                                          INPHYS.3     
*COMDECK LEGAU                                                             LEGAU.1     
      COMMON/LEGAU/ALP(MJP,JGL),DALP(MJP,JGL),RLP(MJP,JGL),RDLP(MJP,JGL)   LEGAU.2     
     :,SI(JGG),AW(JGG),CS(JGG),GWT(JGG),CSSQ(JGG),SISQ(JGG),SECSQ(JGG)     LEGAU.3     
     :,JH,JL,JINC,EXN1,EXN2,EXS1,EXS2,EXE1,EXE2,EXE3                       LEGAU.4     
C                                                                          LEGAU.5     
*COMDECK MSKEQV                                                            MSKEQV.1     
*CALL GRIDP                                                                MSKEQV.2     
      REAL P2MSK(MGP,JGGP)                                                 MSKEQV.3     
      EQUIVALENCE (P2MSK(1,1),UG(1))                                       MSKEQV.4     
C                                                                          MSKEQV.5     
*COMDECK OUTCON                                                            OUTCON.1     
      COMMON/OUTCON/RNTAPE,KOUNTD,KOUNTP,KOUNTF,KOUNTA,KOUNTE              OUTCON.2     
     :,LOUTP,LOUTF,LOUTA,LOUTE,LOUT,NLAT,NLONG,INLAT,INLONG                OUTCON.3     
     :,NPCA,IZGTYP                                                         DIMFILM.1     
     :,NPC1,NCOEFF,INSPC,LSPO(NL)                                          OUTCON.5     
     :,NPC2,LPC2,LSGEDY,LSGGRZ,LSGPLZ,LGPO(NL),LGFO(NL)                    OUTCON.6     
     :     ,LSGGR(NSG),LSGPL(NSG),SGFAC(NSG),SGINC(NSG)                    OUTCON.7     
     :,NPC3,LPC3,LXDGR(NXD),LXDPL(NXD),XDFAC(NXD),XDINC(NXD)               OUTCON.8     
     :,NPC4,LSPPLT,ISPLIT,LNPIC                                            OUTCON.9     
     :,NPC5,LPC5,LENCOP,ECONMX,ECONMN,ENRNGE,ENMX(5),ENMN(5)               OUTCON.10    
     :     ,XUEN,IYEN,IYCON                                                OUTCON.11    
     :,NPC6,LPC6,THSURD(NTHSF),THSURF(NTHSF),LTHGR(NTH),LTHPL(NTH)         OUTCON.12    
     :     ,THFAC(NTH),THINC(NTH)                                          OUTCON.13    
     :,NPC7,LPC7,LPHGR(NPH),LPHPL(NPH),PHFAC(NPH),PHINC(NPH)               OUTCON.14    
     :,NPC8,LPC8,LXPGR(NXP),LXPPL(NXP),XPFAC(NXP),XPINC(NXP)               OUTCON.15    
     :,NPC9,LPC9,LPHCOP                                                    OUTCON.16    
      LOGICAL LOUTP,LOUTF,LOUTA,LOUTE,LOUT                                 OUTCON.17    
     :,LPC2,LPC3,LPC5,LPC6,LPC7,LPC8,LPC9                                  OUTCON.18    
     :,LSPO,LGPO,LGFO,LSGEDY,LSGGRZ,LSGPLZ,LSGGR,LSGPL,LXDGR,LXDPL         OUTCON.19    
     :,LSPPLT,LNPIC,LENCOP,LTHGR,LTHPL,LPHGR,LPHPL,LXPGR,LXPPL,LPHCOP      OUTCON.20    
C                                                                          OUTCON.21    
*COMDECK PHYS                                                              PHYS.1     
      COMMON/PHYS/LBL,LVD,LCR,LLR,LRD,TSTAR(JG,NHEM),QSTAR(JG,NHEM)        PHYS.2     
     :,CD,BLCON,BLVAD,AKVV,ESCONA,ESCONB,FB(NLM)                           PHYS.3     
     :,KBEGP                                                               PHYS.4     
      LOGICAL LBL,LVD,LCR,LLR,LRD                                          PHYS.5     
C                                                                          PHYS.6     
*COMDECK POLYNO                                                            POLYNO.1     
      COMMON/POLYNO/POLY(NWJ2,NHEM),CMPA(IGL)                              POLYNO.2     
      COMPLEX CMPA                                                         POLYNO.3     
C                                                                          POLYNO.4     
*COMDECK SERIES                                                            SERIES.1     
      COMMON/SERIES/ADAY(NPMAX5),AEN(NPMAX5,5),ACONV(NPMAX5,15)            SERIES.2     
C                                                                          SERIES.3     
*COMDECK SPEC                                                              SPEC.1     
      COMMON/SPEC/ZL(NNP,NWP),DL(NNP,NWP),RKE(NNP,NLP,2),RKEFAC            SPEC.2     
     :,EDAY(NPMAX4),NPTS4                                                  SPEC.3     
      COMPLEX ZL,DL                                                        SPEC.4     
C                                                                          SPEC.5     
*COMDECK SPECTR                                                            SPECTR.1     
C     Array ordering in GRIDP and SPECTR must correspond.                  SPECTR.2     
C                                                                          SPECTR.3     
      COMMON/SPECTR/Z(IGB),D(IGB),Q(IGB),H(IGB),T(IGB),SP(IGA)             SPECTR.4     
     :,SPAD(ISPAD),GS(IGA),ZRES(IGN),DRES(IGN),TRES(IGN)                   SPECTR.5     
      COMPLEX Z,D,T,Q,H,SP,GS                                              SPECTR.6     
C                                                                          SPECTR.7     
*COMDECK TAV                                                               TAV.1     
C     Array ordering in ZONAV and TAV must correspond.                     TAV.2     
C                                                                          TAV.3     
      COMMON/TAV/UBT(JGG,NL),THBT(JGG,NL),TBT(JGG,NL),SFMCT(JGG,NL)        TAV.4     
     :,UVBT(JGG,NL),UWBT(JGG,NL),VTBT(JGG,NL),WTBT(JGG,NL),AKZT(JGG,NL)    TAV.5     
     :,AKET(JGG,NL),EPFHT(JGG,NL),EPFVT(JGG,NL),EPDHT(JGG,NL)              TAV.6     
     :,EPDVT(JGG,NL),EPDTT(JGG,NL),ENSQT(JGG,NL)                           TAV.7     
     :,QYT(JGG,NL),TPWNT(JGG,NL),TMTRST(JGG,NL)                            TAV.8     
     :,WBT(JGG,NL),WBTBT(JGG,NL),VBT(JGG,NL),VBTBT(JGG,NL),QBT(JGG,NL)     TAV.9     
     :,RHBT(JGG,NL),VQBT(JGG,NL),WQBT(JGG,NL),HBT(JGG,NL)                  TAV.10    
     :,UUBT(JGG,NL),VVBT(JGG,NL),VWBT(JGG,NL),TTBT(JGG,NL)                 TAV.11    
     :,HTBT(JGG,NL),HBTBT(JGG,NL),FUZRT(JGG,NL),FUERT(JGG,NL)              TAV.12    
     :,TBRES(JGG,NL)                                                       TAV.13    
C                                                                          TAV.14    
*COMDECK WORK                                                              WORK.1     
      COMMON/WORK/IWORK(IDH)                                               WORK.2     
C                                                                          WORK.3     
*COMDECK ZONAV                                                             ZONAV.1     
C     Array ordering in ZONAV and TAV must correspond.                     ZONAV.2     
C                                                                          ZONAV.3     
      COMMON/ZONAV/UBR(JGG,NL),THBR(JGG,NL),TBR(JGG,NL),SFMCR(JGG,NL)      ZONAV.4     
     :,UVBR(JGG,NL),UWBR(JGG,NL),VTBR(JGG,NL),WTBR(JGG,NL),AKZ(JGG,NL)     ZONAV.5     
     :,AKE(JGG,NL),EPFH(JGG,NL),EPFV(JGG,NL),EPDH(JGG,NL),EPDV(JGG,NL)     ZONAV.6     
     :,EPDT(JGG,NL),ENSQ(JGG,NL),QY(JGG,NL),TPWN(JGG,NL),TMTRES(JGG,NL)    ZONAV.7     
     :,WBR(JGG,NL),WBTBR(JGG,NL),VBR(JGG,NL),VBTBR(JGG,NL),QBR(JGG,NL)     ZONAV.8     
     :,RHBR(JGG,NL),VQBR(JGG,NL),WQBR(JGG,NL),HBR(JGG,NL)                  ZONAV.9     
     :,UUBR(JGG,NL),VVBR(JGG,NL),VWBR(JGG,NL),TTBR(JGG,NL)                 ZONAV.10    
     :,HTBR(JGG,NL),HBTBR(JGG,NL),FUZR(JGG,NL),FUER(JGG,NL)                ZONAV.11    
     :,DUBDMU(JGG,NL),DVBDMU(JGG,NL),DTBDMU(JGG,NL)                        ZONAV.12    
     :,UBRP(JGG,NL),VBRP(JGG,NL),STBP(JGG,NL),THBP(JGG,NL),ABSV(JGG,NL)    ZONAV.13    
     :,DUMNZ(JGG,NL),DUMCN(JGG,NL),DUMCK(JGG,NL),DUMBP(JGG,NL)             ZONAV.14    
C                                                                          ZONAV.15    
*COMDECK ZONAVP                                                            ZONAVP.1     
      COMMON/ZONAVP/UTVDZ(IGG,3),VTVDZ(IGG,3),TTVDZ(IGG,3),QTVDZ(IGG,3)    ZONAVP.2     
     :,TTCRZ(IGG,3),QTCRZ(IGG,3),TTLRZ(IGG,3),QTLRZ(IGG,3),TTRDZ(IGG,3)    ZONAVP.3     
     :,UTBLZ(IGG,3),VTBLZ(IGG,3),TTBLZ(IGG,3),QTBLZ(IGG,3)                 ZONAVP.4     
     :,UTOTZ(IGG,3),VTOTZ(IGG,3),TTOTZ(IGG,3),QTOTZ(IGG,3)                 ZONAVP.5     
     :,CTCRZ(IGG,3),CTLRZ(IGG,3)                                           ZONAVP.6     
C                                                                          ZONAVP.7     
*DECK BGFLUX                                                               BGFLUX.1     
      PROGRAM BGFLUX                                                       BGFLUX.2     
C                                                                          BGFLUX.3     
C     ***********************************************************          BGFLUX.4     
C     *                                                         *          BGFLUX.5     
C     * U.K. UNIVERSITIES' GLOBAL ATMOSPHERIC MODELLING PROJECT *          BGFLUX.6     
C     *                                                         *          BGFLUX.7     
C     *   UNIVERSITY OF READING     DEPARTMENT OF METEOROLOGY   *          BGFLUX.8     
C     *                                                         *          BGFLUX.9     
C     *  DIAGNOSTICS PROGRAM FOR INTEGRATIONS OF DRY AND MOIST  *          BGFLUX.10    
C     *      VERSIONS OF READING BAROCLINIC SPECTRAL MODEL      *          BGFLUX.11    
C     *                                                         *          BGFLUX.12    
C     *               MIKE BLACKBURN     19.01.90               *          BGFLUX.13    
C     *                                                         *          BGFLUX.14    
C     ***********************************************************          BGFLUX.15    
C                                                                          BGFLUX.16    
*CALL PARAM1                                                               BGFLUX.17    
*CALL PARAM2                                                               BGFLUX.18    
      PARAMETER(IDDAG=NLWG*IGC,IDSURF=5*IGC)                               BGFLUX.19    
C                                                                          BGFLUX.20    
*CALL BATS                                                                 BGFLUX.21    
*CALL BLANK                                                                BGFLUX.22    
*CALL COMFFT                                                               BGFLUX.23    
*CALL COMIOC                                                               BGFLUX.24    
*CALL COMPRL                                                               BGFLUX.25    
*CALL COMROG                                                               BGFLUX.26    
*CALL GRIDP                                                                BGFLUX.27    
*CALL LEGAU                                                                BGFLUX.28    
*CALL OUTCON                                                               BGFLUX.29    
*CALL PHYS                                                                 BGFLUX.30    
*CALL SPECTR                                                               BGFLUX.31    
      REAL DAG(IDDAG)                                                      BGFLUX.32    
      EQUIVALENCE (DAG(1),UG(1))                                           BGFLUX.33    
C                                                                          BGFLUX.34    
 6000 FORMAT(/' ***WARNING: KNTAV-1.NE.NRTAV - TIME AVERAGES INCORRECT'    BGFLUX.35    
     :       ,' KNTAV  NRTAV = ',2I10/)                                    BGFLUX.36    
 6010 FORMAT(/' ***  EXECUTION TIME =',F10.1,' SECONDS ***'                BGFLUX.37    
     :       /' *** TOTAL TIME USED =',F10.1,' SECONDS ***'/)              BGFLUX.38    
 6900 FORMAT( ' ***ABORT IN GFLUX AT DAY',F10.2                            BGFLUX.39    
     :       ,' : DIABATIC HEATING ON RECORD',I5,' NOT JG+2')              BGFLUX.40    
 6910 FORMAT( ' ***ABORT IN GFLUX AT DAY',F10.2                            BGFLUX.41    
     :       /' ERROR READING SPECTRAL DATA : RMTAPE RLTAPE=',2F20.12)     BGFLUX.42    
C                                                                          UCOS.6     
C     ----------------------------------------------------------------     UCOS.7     
C                                                                          UCOS.8     
C     Open unit 6 explicitly connected to file 'fort.6'.                   UCOS.9     
C                                                                          UCOS.10    
      OPEN(6,FILE='fort.6')                                                UCOS.11    
C                                                                          BGFLUX.43    
C     ----------------------------------------------------------------     BGFLUX.44    
C                                                                          BGFLUX.45    
      CALL SECOND(STIME)                                                   BGFLUX.46    
      CALL INITAL                                                          BGFLUX.47    
      IF (DAMP.GT.0.0) CALL HEXRES                                         BGFLUX.48    
      KOUNT=KSTART-KOUNTD                                                  BGFLUX.49    
      KNTAV=0                                                              BGFLUX.50    
C                                                                          BGFLUX.51    
C     ----------------------------------------------------------------     BGFLUX.52    
C                                                                          BGFLUX.53    
C     Main loop over analysis times.                                       BGFLUX.54    
C                                                                          BGFLUX.55    
   10 CONTINUE                                                             BGFLUX.56    
      KOUNT=KOUNT+KOUNTD                                                   BGFLUX.57    
      KNTAV=KNTAV+1                                                        BGFLUX.58    
      LOUTP=KOUNTP.GT.0 .AND. KOUNT.EQ.KOUNTP*(KOUNT/KOUNTP)               BGFLUX.59    
     :                  .AND. NLAT.GT.0                                    BGFLUX.60    
      LOUTF=KOUNTF.GT.0 .AND. KOUNT.EQ.KOUNTF*(KOUNT/KOUNTF)               BGFLUX.61    
      LOUTA=KOUNTA.GT.0 .AND. KOUNT.EQ.KOUNTA*(KOUNT/KOUNTA)               BGFLUX.62    
      LOUTE=KOUNTE.GT.0 .AND.(KOUNT.EQ.KOUNTE*(KOUNT/KOUNTE)               BGFLUX.63    
     :                        .OR.KOUNT.EQ.KHDAY)                          BGFLUX.64    
      LOUT =LOUTP.OR.LOUTF.OR.LOUTA                                        BGFLUX.65    
      IF (LPC6.AND.LOUT) REWIND NCTHG                                      BGFLUX.66    
      DO 20 I=1,NGP                                                        BGFLUX.67    
   20 REWIND NCGP(I)                                                       BGFLUX.68    
C                                                                          BGFLUX.69    
C     First process (JG+2) records of parameterisation diagnostics.        BGFLUX.70    
C     PHYSOP uses common SPECTR for workspace.                             BGFLUX.71    
C                                                                          BGFLUX.72    
      IF (KOUNT.GT.KBEGP) THEN                                             BGFLUX.73    
         CALL PHYSOP                                                       BGFLUX.74    
         CALL PHYSEC                                                       BGFLUX.75    
         CALL RCHECK(NCHIST,RNTAPE,KOUNT,TSPD)                             BGFLUX.76    
         READ(NCHIST) RKOUNT,RMTAPE,DAY,RNR,H,RMTAPE                       BGFLUX.77    
         IF (NINT(RNR).NE.JG+2) THEN                                       BGFLUX.78    
            WRITE(6,6900) DAY,RNR                                          BGFLUX.79    
            CALL ABORT                                                     BGFLUX.80    
         ENDIF                                                             BGFLUX.81    
      ELSE                                                                 BGFLUX.82    
         DO 30 I=1,IGB                                                     BGFLUX.83    
   30    H(I)=CMPLX(0.,0.)                                                 BGFLUX.84    
      ENDIF                                                                BGFLUX.85    
C                                                                          BGFLUX.86    
C     Spectral data now processed.                                         BGFLUX.87    
C                                                                          BGFLUX.88    
      CALL RCHECK(NCHIST,RNTAPE,KOUNT,TSPD)                                BGFLUX.89    
      IF (.NOT.LDRY) THEN                                                  BGFLUX.90    
         READ(NCHIST) RKOUNT,RMTAPE,DAY,Z,D,T,Q,SP,RLTAPE                  BGFLUX.91    
      ELSE                                                                 BGFLUX.92    
         READ(NCHIST) RKOUNT,RMTAPE,DAY,Z,D,T,SP,RLTAPE                    BGFLUX.93    
         DO 40 I=1,IGB                                                     BGFLUX.94    
   40    Q(I)=CMPLX(0.,0.)                                                 BGFLUX.95    
      ENDIF                                                                BGFLUX.96    
      IF (RLTAPE.NE.RMTAPE) THEN                                           BGFLUX.97    
         WRITE(6,6910) DAY,RMTAPE,RLTAPE                                   BGFLUX.98    
         CALL ABORT                                                        BGFLUX.99    
      ENDIF                                                                BGFLUX.100   
      KONTM=NINT(RKOUNT)                                                   BGFLUX.101   
C                                                                          BGFLUX.102   
      IF (LPC5) CALL LTEND                                                 BGFLUX.103   
      IF (LOUTE) CALL NSPECT                                               BGFLUX.104   
      IF (NCOEFF.GT.0.AND.LOUTP) CALL OPCOEF                               BGFLUX.105   
      IF (.NOT.(LPC2.OR.LPC3.OR.LPC5.OR.LPC6)) GOTO 110                    BUGS5.34    
C                                                                          BGFLUX.107   
C     Loop over latitude for spectral to grid transform.                   BGFLUX.108   
C                                                                          BGFLUX.109   
      IF (JGL.EQ.1) THEN                                                   BGFLUX.110   
         REWIND NCLEG                                                      BGFLUX.111   
         IF (LROG) REWIND NCROGG                                           BGFLUX.112   
      ENDIF                                                                BGFLUX.113   
      JL=1                                                                 BGFLUX.114   
      DO 100 IH=1,JG                                                       BGFLUX.115   
      JH=IH                                                                BGFLUX.116   
      IF (JGL.EQ.1) THEN                                                   BGFLUX.117   
         READ(NCLEG) ALP,DALP,RLP,RDLP                                     BGFLUX.118   
         IF (LROG) READ(NCROGG) GSG                                        BGFLUX.119   
      ENDIF                                                                BGFLUX.120   
      CALL LTI                                                             BGFLUX.121   
      IF (NTWG.EQ.0) GOTO 60                                               BGFLUX.122   
      DO 50 I=1,NTWG                                                       BGFLUX.123   
   50 CALL FFT991(DAG(1+(I-1)*NCRAY*MGPP),WORK,TRIG,IFAX                   BGFLUX.124   
     :           ,1,MGPP,MG,NCRAY,1)                                       BGFLUX.125   
   60 CALL FFT991(DAG(1+NTWG*NCRAY*MGPP),WORK,TRIG,IFAX                    BGFLUX.126   
     :           ,1,MGPP,MG,NRSTWG,1)                                      BGFLUX.127   
      CALL GRMULT                                                          BGFLUX.128   
      IF (.NOT.LINTP2) WRITE(NCGP(1)) SFG                                  BGFLUX.129   
      WRITE(NCGP( 2)) ZG                                                   BGFLUX.130   
      WRITE(NCGP( 3)) DG                                                   BGFLUX.131   
      WRITE(NCGP( 4)) OMG                                                  BGFLUX.132   
      WRITE(NCGP( 5)) UG                                                   BGFLUX.133   
      WRITE(NCGP( 6)) VG                                                   BGFLUX.134   
      WRITE(NCGP( 7)) TG                                                   BGFLUX.135   
      WRITE(NCGP( 8)) GHG                                                  BGFLUX.136   
      WRITE(NCGP( 9)) QG                                                   BGFLUX.137   
      WRITE(NCGP(10)) HG                                                   BGFLUX.138   
      WRITE(NCGP(11)) PLG,PMG,PJG                                          BGFLUX.139   
      WRITE(NCGP(12)) PMSLG                                                BGFLUX.140   
      WRITE(NCGP(13)) FUG                                                  BGFLUX.141   
      WRITE(NCGP(14)) FVG                                                  BGFLUX.142   
      IF (LPC6.AND.LOUT) WRITE(NCTHG) UTHG,VTHG,ERTHG,PTHG                 BGFLUX.143   
      JL=JL+JINC                                                           BGFLUX.144   
  100 CONTINUE                                                             BGFLUX.145   
C                                                                          BGFLUX.146   
C     Common SPECTR now free to be used as work space.                     BGFLUX.147   
C                                                                          BGFLUX.148   
      IF (LINTP2) CALL SFGCPR                                              BGFLUX.149   
      IF (LPC3.OR.LPC5) CALL FLUX                                          BGFLUX.150   
      IF (LPC5) CALL GDIAG                                                 BGFLUX.151   
      IF (LOUT) THEN                                                       BGFLUX.152   
         CALL INIMSK                                                       BGFLUX.153   
         IF (LPC2) CALL OPGRID                                             BGFLUX.154   
         IF (LPC6) CALL OPERTEL                                            BGFLUX.155   
         IF (LPC3) CALL FLXPRC                                             BGFLUX.156   
      ENDIF                                                                BGFLUX.157   
C                                                                          BUGS5.35    
  110 CONTINUE                                                             BUGS5.36    
C                                                                          BGFLUX.158   
      IF (KOUNT.LT.KEND) GOTO 10                                           BGFLUX.159   
C                                                                          BGFLUX.160   
C     ----------------------------------------------------------------     BGFLUX.161   
C                                                                          BGFLUX.162   
C     Time series of global diagnostics and time averaged sections.        BGFLUX.163   
C                                                                          BGFLUX.164   
      IF (NRTAV.GT.0.AND.KNTAV-1.NE.NRTAV) THEN                            BGFLUX.165   
         WRITE(6,6000)                                                     BGFLUX.166   
         WRITE(NCFICH,6000)                                                BGFLUX.167   
      ENDIF                                                                BGFLUX.168   
      KOUNT=-999                                                           BGFLUX.169   
      DAY=-999.                                                            BGFLUX.170   
      LOUTP=KOUNTP.GT.0                                                    BGFLUX.171   
      LOUTF=KOUNTF.GT.0                                                    BGFLUX.172   
      LOUTA=KOUNTA.GT.0                                                    BGFLUX.173   
      LOUT =LOUTP.OR.LOUTF.OR.LOUTA                                        BGFLUX.174   
      IF (LPC5) CALL GDIAG                                                 BGFLUX.175   
      IF (LPC3.AND.LTAV.AND.LOUT) CALL FLXPRC                              BGFLUX.176   
      IF (KEND.GT.KBEGP) THEN                                              BGFLUX.177   
         IF (LPC9) CALL PHYSAV                                             BGFLUX.178   
         IF (LPC8.AND.LTAV.AND.LOUT) CALL PHYSEC                           BGFLUX.179   
      ENDIF                                                                BGFLUX.180   
C                                                                          BGFLUX.181   
C     Copy all KE spectra data from scratch files to channel NCPLOT(1)     BGFLUX.182   
C     for subsequent plotting job.                                         BGFLUX.183   
C                                                                          BGFLUX.184   
      IF (KOUNTE.GT.0.AND.LSPPLT) CALL NSPECT                              BGFLUX.185   
      IF (LSPPLT.OR.LENCOP.OR.LPHCOP) REWIND NCPLOT(1)                     BGFLUX.186   
C                                                                          BGFLUX.187   
C     Close Dimfilm plot file and data transfer file (UTF).                BGFLUX.188   
C                                                                          BGFLUX.189   
      IF (LOUTA) CALL ENDUTF(NPCA)                                         BGFLUX.191   
C                                                                          BGFLUX.192   
C                                                                          BGFLUX.194   
      IF (JGL.EQ.1) THEN                                                   BGFLUX.195   
  210    CONTINUE                                                          BGFLUX.230   
      ENDIF                                                                BGFLUX.231   
C                                                                          BGFLUX.232   
C     Write CPU timing to output and fiche channels.                       BGFLUX.233   
C                                                                          BGFLUX.234   
      CALL SECOND(FTIME)                                                   BGFLUX.235   
      ETIME=FTIME-STIME                                                    BGFLUX.236   
      WRITE(6,6010) ETIME,FTIME                                            BGFLUX.237   
      WRITE(NCFICH,6010) ETIME,FTIME                                       BGFLUX.238   
C                                                                          BGFLUX.239   
      STOP                                                                 BGFLUX.240   
      END                                                                  BGFLUX.241   
C     ****************************************************************     BGFLUX.242   
*DECK INITAL                                                               INITAL.1     
      SUBROUTINE INITAL                                                    INITAL.2     
C                                                                          INITAL.3     
*CALL PARAM1                                                               INITAL.4     
*CALL PARAM2                                                               INITAL.5     
*CALL BATS                                                                 INITAL.6     
*CALL BLANK                                                                INITAL.7     
*CALL COMFFT                                                               INITAL.8     
*CALL COMIOC                                                               INITAL.9     
*CALL COMMSK                                                               INITAL.10    
*CALL COMPRL                                                               INITAL.11    
*CALL COMROG                                                               INITAL.12    
*CALL LEGAU                                                                INITAL.14    
*CALL OUTCON                                                               INITAL.15    
*CALL PHYS                                                                 INITAL.16    
*CALL POLYNO                                                               INITAL.17    
*CALL SPEC                                                                 INITAL.18    
*CALL SPECTR                                                               INITAL.19    
*CALL TAV                                                                  INITAL.20    
      CHARACTER*8 NAME(2)                                                  SUNMOD.76    
      REAL HEIGHT(NL),CR(NL),CI(NL),TBM1(NL2)                              INITAL.22    
      REAL DDZT(IDDZ)                                                      INITAL.23    
      EQUIVALENCE (DDZT(1),UBT(1,1))                                       INITAL.24    
      CHARACTER LCENTR*3                                                   INITAL.25    
C                                                                          INITAL.26    
C     Set channel numbers.                                                 INITAL.27    
C                                                                          INITAL.28    
      DATA                                                                 INITAL.29    
     : NCFICH/3/                                                           INITAL.30    
     :,NCHIST,NCREST,NCSURF/10,13,14/                                      INITAL.31    
     :,NCROGG,NCROGS/15,16/                                                INITAL.32    
     :,NCSTH/17/,NCST4/18,19/                                              INITAL.33    
     :,NCPLOT/22,21,20/                                                    INITAL.34    
     :,NCLEG/25/                                                           INITAL.35    
     :,NCGEN,NCGDG,NCTHG/38,39,40/                                         INITAL.36    
     :,NCGP/41,42,43,44,45,46,47,48,49,50,51,52,53,54/                     INITAL.37    
     :,NCDIM/63/                                                           INITAL.38    
C                                                                          INITAL.39    
C     Default values for namelist INPB.                                    INITAL.40    
C                                                                          INITAL.41    
      DATA                                                                 INITAL.42    
     : LSSD/.FALSE./                                                       SUNMOD.1     
     :,GA,RD,RV,AKAP,CLATNT,RADEA,WW,P0/9.81,287.,461.51,.286,2.5E6        INITAL.44    
     :,6.371E6,7.292E-5,1.E5/                                              INITAL.45    
     :,TDISS,NDEL/.125,8/,RESTIM/0./,DRAG/NL*0./                           INITAL.46    
     :,NPC1,NPC2,NPC3,NPC4,NPC5,NPC6,NPC7,NPC8,NPC9/9*3/,NPCA/65/          INITAL.47    
     :,LPC2/.FALSE./,LPC3,LPC5/2*.TRUE./,LPC6,LPC7/2*.FALSE./,LPC8,LPC9/   SUNMOD.2     
     : 2*.TRUE./                                                           SUNMOD.3     
     :,NCOEFF,NLAT,NLONG/NN,JG,MG/                                         INITAL.49    
C                                                                          INITAL.50    
      DATA                                                                 INITAL.51    
     : LSPO/NL*.FALSE./,LGPO/NL*.FALSE./,LGFO/NL*.FALSE./                  SUNMOD.4     
     :,LSGEDY,LSGGRZ,LSGPLZ/.FALSE.,.TRUE.,.FALSE./,LSGGR/10*.TRUE.,       SUNMOD.5     
     :.FALSE.,.TRUE./                                                      SUNMOD.6     
     :,LSGPL/2*.TRUE.,.FALSE.,.TRUE.,2*.FALSE.,.TRUE.,.FALSE.,2*.TRUE.,    SUNMOD.7     
     :.FALSE.,.TRUE./                                                      SUNMOD.8     
     :,SGFAC/1.E6,1.E-6,1.E-7,.1,.1,.1,.1,10.,.1,.1,1.,.1/                 INITAL.55    
     :,SGINC/1.E7,1.E-5,1.E-6,1.,0.,0.,4.,200.,1.,1.,20.,4./               INITAL.56    
     :,LXDGR/28*.TRUE./,LXDPL/10*.TRUE.,4*.FALSE.,6*.TRUE.,.FALSE.,        SUNMOD.9     
     :.TRUE.,.FALSE.,5*.TRUE./                                             SUNMOD.10    
     :,XDFAC/3*.1,1.E9,1.,.1,1.,.1,2*10.,1.E14,1.E19,3*1.E14,1.E-5         INITAL.58    
     :,      1.E-12,3*.1,1.,.01,1.,.1,1.,3*.1/                             INITAL.59    
     :,XDINC/3*5.,7*-.1,4*0.,4.E15,5.E-5,2.E-11,2.,1.,4*-.1                INITAL.60    
     :,      1.,10.,2*-.1,.5/                                              INITAL.61    
     :,LSPPLT/.FALSE./,ISPLIT/100/,LENCOP/.FALSE./                         SUNMOD.11    
     :,ECONMX,ECONMN,ENRNGE/10.,-10.,2.E6/,ENMN/1.5E7,1.5E6,3*0./          INITAL.63    
     :,XUEN,IYEN,IYCON/.2,20,20/                                           INITAL.64    
C                                                                          INITAL.65    
      DATA                                                                 INITAL.66    
     : THSURD/350.,330.,310.,295.,280./                                    INITAL.67    
     :,CPHASE/0./,LTHGR/4*.FALSE./,LTHPL/4*.FALSE./                        SUNMOD.12    
     :,THFAC/3*.1,1./,THINC/2*0.,.5,50./                                   INITAL.69    
     :,LPHGR/6*.FALSE./,LPHPL/6*.FALSE./,LPHCOP/.FALSE./                   SUNMOD.13    
     :,PHFAC/.01,2*1.,3*.1/,PHINC/.1,2*25.,3*5./                           INITAL.72    
     :,LXPGR/19*.TRUE./,LXPPL/13*.FALSE.,4*.TRUE.,2*.FALSE./               SUNMOD.14    
     :,XPFAC/17*.1,2*1./,XPINC/2*5.,7*.5,2*5.,2*.5,2*5.,2*.5,2*0./         INITAL.74    
C                                                                          INITAL.75    
      DATA                                                                 INITAL.76    
     :IZGTYP/4/,NAME/'NO-ONE','    '/                                      DIMFILM.3     
C                                                                          INITAL.79    
      DATA                                                                 INITAL.80    
     : LINTP2,LINTP3/.FALSE.,.TRUE./,LXTRP2,LXTRP3/2*.TRUE./               SUNMOD.15    
     :,NLPR/0/,PLOUT/NL*0./                                                INITAL.82    
     :,LROG,LROGGR,LROGPL/3*.FALSE./,ROGFAC,ROGINC/10.,200./               SUNMOD.16    
     :,LMSK2,LMSK3/2*.FALSE./                                              SUNMOD.17    
C                                                                          INITAL.85    
C     Default values for namelist INPHYS.                                  INITAL.86    
C                                                                          INITAL.87    
      DATA                                                                 INITAL.88    
     : BEGDP/0./,LDRY/.FALSE./                                             SUNMOD.18    
     :,LBL,LVD,LCR,LLR,LRD/5*.FALSE./,CD,AKVV/.001,1./                     SUNMOD.19    
C                                                                          INITAL.91    
C     Remaining initial data.                                              INITAL.92    
C                                                                          INITAL.93    
      DATA SECHR/3600./                                                    INITAL.94    
      DATA LCENTR/'RAL'/                                                   INITAL.95    
C                                                                          INITAL.96    
*CALL INPB                                                                 INITAL.97    
*CALL INPHYS                                                               INITAL.98    
 6000 FORMAT(///' **** RNTAPE',F9.3,' ****',15X                            INITAL.99    
     :         ,' **** BGCMFLUX DIAGNOSTICS ****'                          INITAL.100   
     :        //' INTEGRATION WITH ',I3                                    INITAL.101   
     :         ,' LEVELS IN THE VERTICAL (NL=',I3,')'                      INITAL.102   
     :        //' JAGGED TRAPEZOIDAL/TRIANGULAR TRUNCATION AT TOTAL'       INITAL.103   
     :         ,' WAVENO.',I3,' AND ZONAL WAVENO.',I3                      INITAL.104   
     :         ,' (NN=',I3,' MM=',I3,')')                                  INITAL.105   
 6010 FORMAT(/' NHEM=',I1,' GLOBAL DOMAIN: BOTH EVEN AND ODD'              INITAL.106   
     :       ,' COEFFICIENTS INCLUDED')                                    INITAL.107   
 6020 FORMAT(/' NHEM=',I1,' HEMISPHERIC DOMAIN: ONLY EVEN DIVERGENCE,'     INITAL.108   
     :       ,' TEMPERATURE AND SURFACE PRESSURE'                          INITAL.109   
     :       /' AND ODD VORTICITY COEFFICIENTS INCLUDED')                  INITAL.110   
 6030 FORMAT(/I3,'-FOLD SYMMETRY IN LONGITUDE IMPOSED AND ONLY 1 /'        INITAL.111   
     :       ,I2,' OF THE DOMAIN USED (MOCT=',I2,')')                      INITAL.112   
 6040 FORMAT(/' NON LINEAR TERMS EVALUATED ON GRID OF',I3                  INITAL.113   
     :       ,' GAUSSIAN LATITUDES AND',I4                                 INITAL.114   
     :       ,' EVENLY SPACED LONGITUDES (JG=',I3,' MG=',I3,')')           INITAL.115   
 6050 FORMAT(/' ECMWF ANGULAR MOMENTUM CONSERVING INTEGRATION')            INITAL.116   
 6060 FORMAT(/' DEL',I2,' DISSIPATION WITH COEFFICIENT',1PE12.5,0P         INITAL.117   
     :       ,' M',I1,'/S'                                                 INITAL.118   
     :       /' E-FOLDING TIME FOR SMALLEST RESOLVED SCALE IS ',F5.3       INITAL.119   
     :       ,' SIDEREAL DAYS')                                            INITAL.120   
 6070 FORMAT(/' NO DISSIPATION')                                           INITAL.121   
 6080 FORMAT(/' RESTORATION ON A TIME SCALE OF',F4.1,' DAYS')              INITAL.122   
 6090 FORMAT(/' NO RESTORATION')                                           INITAL.123   
 6100 FORMAT( ' NAME IS ',2A8)                                             INITAL.124   
 6110 FORMAT(/' GAUSSIAN LATITUDES (DEG)'/(20F6.1))                        INITAL.125   
 6120 FORMAT(/' SIGMA AT HALF LEVELS'/(15F7.4))                            INITAL.126   
 6130 FORMAT(/' SIGMA AT FULL LEVELS'/(15F7.4))                            INITAL.127   
 6140 FORMAT(/' BASIC STATE HEIGHTS (KM)'/(15F7.3))                        INITAL.128   
 6150 FORMAT(/' GRAVITY WAVE SPEEDS (M/S)'/(15F7.2))                       INITAL.129   
 6200 FORMAT(/' DRY HISTORY FILE PROCESSED : NO PARAMETERISATIONS')        INITAL.130   
 6210 FORMAT(/' PARAMETERISATION DIAGNOSTICS INCLUDED FOR :')              INITAL.131   
 6220 FORMAT(/' NO PARAMETERISATION DIAGNOSTICS INCLUDED')                 INITAL.132   
 6230 FORMAT( ' SURFACE FLUXES : CD =',F10.4)                              INITAL.133   
 6240 FORMAT( ' DRY AND MOIST CONVECTION')                                 INITAL.134   
 6250 FORMAT( ' LARGE-SCALE CONDENSATION TO SATURATION IN TIMESTEP')       INITAL.135   
 6260 FORMAT( ' RADIATION : UNIFORM COOLING BELOW 200MB')                  INITAL.136   
 6270 FORMAT( ' VERTICAL DIFFUSION INCLUDING FOR MOMENTUM AKVV=',F8.2)     INITAL.137   
 6280 FORMAT(///' PATH NAMES FOR DIRECTORIES ARE:'/' TEMP    DIR : ',A     UCOS.19    
     :         /' HOME    DIR : ',A/' CURRENT DIR : ',A///)                UCOS.20    
 6900 FORMAT(/' ***ABORT IN INITAL : PADDING ARRAY IN SPECTR IS TOO'       PADLEN.7     
     :       ,' SHORT : INCREASE FROM',I8,' TO',I8)                        PADLEN.8     
 6901 FORMAT(/' ***CAUTION : PADDING ARRAY IN SPECTR IS LONGER THAN'       PADLEN.9     
     :       ,' NECESSARY : CAN REDUCE FROM',I8,' TO',I8)                  PADLEN.10    
 6913 FORMAT( ' ***CHECK CALCULATION OF PARAMETERS AND TOP OF INITAL'      PADLEN.11    
     :       /' SPECTRAL LENGTH ILS1 =',I8                                 PADLEN.12    
     :       /' EQUIVALENCED ARRAY LENGTHS =',10I8)                        PADLEN.13    
 6914 FORMAT(/' PARAM  : MAX EQUIV LENGTH =',I8,' : PAD LENGTH =',I8       PADLEN.14    
     :       /' INITAL : MAX EQUIV LENGTH =',I8,' : PAD LENGTH =',I8/)     PADLEN.15    
 6902 FORMAT(/' ***ABORT IN INITAL: JGL MUST BE EITHER 1 OR JG')           INITAL.145   
 6903 FORMAT(/' ***ABORT IN INITAL: KOUNTD MUST BE NON-ZERO')              INITAL.146   
 6904 FORMAT(/' ***ABORT IN INITAL: KOUNTP MUST BE MULTIPLE OF KOUNTD')    INITAL.147   
 6905 FORMAT(/' ***ABORT IN INITAL: KOUNTF MUST BE MULTIPLE OF KOUNTD')    INITAL.148   
 6906 FORMAT(/' ***ABORT IN INITAL: KOUNTA MUST BE MULTIPLE OF KOUNTD')    INITAL.149   
 6907 FORMAT(/' ***ABORT IN INITAL: KOUNTE MUST BE MULTIPLE OF KOUNTD')    INITAL.150   
 6908 FORMAT(/' ***ABORT IN INITAL: NLAT VALUE INVALID')                   INITAL.151   
 6909 FORMAT(/' ***ABORT IN INITAL: NLONG VALUE INVALID')                  INITAL.152   
 6910 FORMAT(/' ***ABORT IN INITAL: NCOEFF VALUE INVALID')                 INITAL.153   
 6911 FORMAT(/' ***WARNING: ATTEMPT TO CONTOUR ISENTROPIC WINDS:'          INITAL.154   
     :        ' LTHPL(1) AND LTHPL(2) SWITCHED OFF')                       INITAL.155   
 6912 FORMAT(/' ***ABORT IN INITAL: PARAMETER NWJ2 INCONSISTENT WITH'      INITAL.156   
     :        ' RESOLUTION PARAMETERS NN AND MM: NWJ2, NWJC =',2I5)        INITAL.157   
C                                                                          INITAL.158   
C     Check supplied parameters.                                           INITAL.159   
C     Any changes to spectral arrays or equivalenced grid point arrays     PADLEN.16    
C     should be reflected both here and in the parameter statement         PADLEN.17    
C     where the spectral padding array length is calculated.               PADLEN.18    
C     This code checks the necessarily complicated parameter calcs.        PADLEN.19    
C                                                                          PADLEN.20    
      ILGMX=MAX0(ILG2,ILG6,ILG7)                                           PADLEN.21    
      IPDMX=MAX0(ILGMX-ILS1,2)                                             PADLEN.22    
      IF (ISPAD.LT.IPDMX) THEN                                             PADLEN.23    
         WRITE(6,6900) ISPAD,IPDMX                                         PADLEN.24    
         WRITE(6,6913) ILS1,ILG2,ILG6,ILG7                                 PADLEN.25    
         WRITE(6,6914) ILGB,ISPAD,ILGMX,IPDMX                              PADLEN.26    
         CALL ABORT                                                        PADLEN.27    
      ELSE IF (ISPAD.GT.IPDMX) THEN                                        PADLEN.28    
         WRITE(6,6901) ISPAD,IPDMX                                         PADLEN.29    
         WRITE(6,6913) ILS1,ILG2,ILG6,ILG7                                 PADLEN.30    
         WRITE(6,6914) ILGB,ISPAD,ILGMX,IPDMX                              PADLEN.31    
      ENDIF                                                                PADLEN.32    
C                                                                          PADLEN.33    
      IF (JGL.NE.1.AND.JGL.NE.JG) THEN                                     INITAL.173   
      WRITE(6,6902)                                                        INITAL.174   
      CALL ABORT                                                           INITAL.175   
      ENDIF                                                                INITAL.176   
C                                                                          INITAL.177   
C     Derive spectral constants from resolution parameters.                INITAL.178   
C                                                                          INITAL.179   
      MF=MM-1                                                              INITAL.180   
      MFP=MM                                                               INITAL.181   
      MFPP=MM+1                                                            INITAL.182   
      NF=NN-1                                                              INITAL.183   
      NFP=NN                                                               INITAL.184   
      NFPP=NN+1                                                            INITAL.185   
C                                                                          UCOS.21    
C     Read character strings containing absolute path names                UCOS.22    
C     for temporary, home and current directories.  Stored in COMIOL.      UCOS.23    
C                                                                          UCOS.24    
      CBLANK=' '                                                           UCOS.25    
      WRITE(CPTHTD,'(80A1)') (CBLANK,I=1,80)                               UCOS.26    
      WRITE(CPTHHD,'(80A1)') (CBLANK,I=1,80)                               UCOS.27    
      WRITE(CPTHWD,'(80A1)') (CBLANK,I=1,80)                               UCOS.28    
      READ(5,'(A)') CPTHTD                                                 UCOS.29    
      READ(5,'(A)') CPTHHD                                                 UCOS.30    
      READ(5,'(A)') CPTHWD                                                 UCOS.31    
      NLENTD=LENSIG(CPTHTD)                                                UCOS.32    
      NLENHD=LENSIG(CPTHHD)                                                UCOS.33    
      NLENWD=LENSIG(CPTHWD)                                                UCOS.34    
      WRITE(6,6280) CPTHTD(1:NLENTD),CPTHHD(1:NLENHD),CPTHWD(1:NLENWD)     UCOS.35    
C                                                                          INITAL.186   
C     Read namelists INPB & INPHYS.                                        INITAL.187   
C     Defaults set in data statements above.                               INITAL.188   
C                                                                          INITAL.189   
      READ(5,INPB)                                                         INITAL.190   
      READ(5,INPHYS)                                                       INITAL.191   
C                                                                          INITAL.192   
C     Remaining dimensional factors, fundamental and derived constants.    INITAL.193   
C                                                                          INITAL.194   
      CMBHR=.01*WW*SECHR*P0                                                INITAL.195   
      CV=RADEA*WW                                                          INITAL.196   
      CG=CV*CV                                                             INITAL.197   
      CT=CG/RD                                                             INITAL.198   
      CQ=1000.                                                             INITAL.199   
      CTT=PI2*CT                                                           INITAL.200   
      CEP=PI2*RADEA*RADEA*CG/GA                                            INITAL.201   
      CERT=CT*WW*GA/P0                                                     INITAL.202   
C                                                                          INITAL.203   
      CPD=RD/AKAP                                                          INITAL.204   
      EZ=1./SQRT(.375)                                                     INITAL.205   
      XLAPSE=.0065*RD/GA                                                   INITAL.206   
C                                                                          INITAL.207   
      NW=1+MF/MOCT                                                         INITAL.208   
      RMG=1./MG                                                            INITAL.209   
C                                                                          INITAL.210   
C     Print description of run.                                            INITAL.211   
C                                                                          INITAL.212   
      WRITE(6,6000) RNTAPE,NL,NL,NN,MF,NN,MM                               INITAL.213   
      IF (NHEM.EQ.2) WRITE(6,6010)NHEM                                     INITAL.214   
      IF (NHEM.EQ.1) WRITE(6,6020)NHEM                                     INITAL.215   
      WRITE(6,6030) MOCT,MOCT,MOCT                                         INITAL.216   
      WRITE(6,6040) JG,MG,JG,MG                                            INITAL.217   
      WRITE(6,6050)                                                        INITAL.218   
C                                                                          INITAL.219   
C     Constants for horizontal diffusion and linear restoration.           INITAL.220   
C                                                                          INITAL.221   
      IF (TDISS.GT.0.) THEN                                                INITAL.222   
         AKK=WW*(RADEA**NDEL)/(PI2*TDISS*((NN*(NN+1))**(NDEL/2)))          INITAL.223   
         WRITE(6,6060) NDEL,AKK,NDEL,TDISS                                 INITAL.224   
         AKK=AKK*CG*P0/(GA*(RADEA**NDEL))                                  INITAL.225   
      ELSE                                                                 INITAL.226   
         AKK=0.                                                            INITAL.227   
         WRITE(6,6070)                                                     INITAL.228   
      ENDIF                                                                INITAL.229   
      NDELH=NDEL/2                                                         INITAL.230   
      NDELHM=NDELH-1                                                       INITAL.231   
C                                                                          INITAL.232   
      IF (RESTIM.GT.0.) THEN                                               INITAL.233   
         WRITE(6,6080) RESTIM                                              INITAL.234   
         DAMP=WW*CG*P0/(GA*RESTIM*PI2)                                     INITAL.235   
         READ(NCREST) ZRES,DRES,TRES                                       INITAL.236   
      ELSE                                                                 INITAL.237   
         WRITE(6,6090)                                                     INITAL.238   
         DAMP=0.                                                           INITAL.239   
         DO 10 I=1,IGN                                                     INITAL.240   
         ZRES(I)=0.                                                        INITAL.241   
         DRES(I)=0.                                                        INITAL.242   
         TRES(I)=0.                                                        INITAL.243   
   10    CONTINUE                                                          INITAL.244   
      ENDIF                                                                INITAL.245   
      DO 20 L=1,NL                                                         INITAL.246   
      DO 20 I=1,JGG                                                        INITAL.247   
      TBRES(I,L)=0.                                                        INITAL.248   
   20 CONTINUE                                                             INITAL.249   
C                                                                          INITAL.250   
C     Switch off output of moisture and heating fields if dry history.     INITAL.251   
C                                                                          INITAL.252   
      IF (LDRY) THEN                                                       INITAL.253   
         DO 30 IOUT=9,10                                                   INITAL.254   
         LSGGR(IOUT)=.FALSE.                                               SUNMOD.20    
   30    LSGPL(IOUT)=.FALSE.                                               SUNMOD.21    
         DO 40 IOUT=24,28                                                  INITAL.257   
         LXDGR(IOUT)=.FALSE.                                               SUNMOD.22    
   40    LXDPL(IOUT)=.FALSE.                                               SUNMOD.23    
      ENDIF                                                                INITAL.260   
C                                                                          INITAL.261   
C     Echo namelist to output channel.                                     INITAL.262   
C                                                                          INITAL.263   
      WRITE(6,'('' '')')                                                   INITAL.264   
      WRITE(6,INPB)                                                        INITAL.265   
      WRITE(6,6100) NAME                                                   INITAL.266   
C                                                                          INITAL.267   
C     Check and modify the basic counters, derive others.                  INITAL.268   
C                                                                          INITAL.269   
      IF (KOUNTD.EQ.0) THEN                                                INITAL.270   
         WRITE(6,6903)                                                     INITAL.271   
         CALL ABORT                                                        INITAL.272   
      ENDIF                                                                INITAL.273   
      IF (KOUNTP.NE.KOUNTD*(KOUNTP/KOUNTD)) THEN                           INITAL.274   
         WRITE(6,6904)                                                     INITAL.275   
         CALL ABORT                                                        INITAL.276   
      ENDIF                                                                INITAL.277   
      IF (KOUNTF.NE.KOUNTD*(KOUNTF/KOUNTD)) THEN                           INITAL.278   
         WRITE(6,6905)                                                     INITAL.279   
         CALL ABORT                                                        INITAL.280   
      ENDIF                                                                INITAL.281   
      IF (KOUNTA.NE.KOUNTD*(KOUNTA/KOUNTD)) THEN                           INITAL.282   
         WRITE(6,6906)                                                     INITAL.283   
         CALL ABORT                                                        INITAL.284   
      ENDIF                                                                INITAL.285   
      IF (KOUNTE.NE.KOUNTD*(KOUNTE/KOUNTD)) THEN                           INITAL.286   
         WRITE(6,6907)                                                     INITAL.287   
         CALL ABORT                                                        INITAL.288   
      ENDIF                                                                INITAL.289   
      IF (KOUNTP.EQ.0) KOUNTP=-999999999                                   INITAL.290   
      IF (KOUNTF.EQ.0) KOUNTF=-999999999                                   INITAL.291   
      IF (KOUNTA.EQ.0) KOUNTA=-999999999                                   INITAL.292   
      IF (KOUNTE.EQ.0) KOUNTE=-999999999                                   INITAL.293   
      KHDAY =NINT(    .5*TSPD)                                             INITAL.294   
      KSTART=NINT(BEGDAY*TSPD)                                             INITAL.295   
      KEND  =NINT(ENDDAY*TSPD)                                             INITAL.296   
      KBEGP =NINT( BEGDP*TSPD)                                             INITAL.297   
      IF (LDRY) KBEGP=KEND+999                                             INITAL.298   
C                                                                          INITAL.299   
C     Check various namelist values.                                       INITAL.300   
C                                                                          INITAL.301   
      IF (NLAT.LT.0.OR.NLAT.GT.JG) THEN                                    INITAL.302   
         WRITE(6,6908)                                                     INITAL.303   
         CALL ABORT                                                        INITAL.304   
      ENDIF                                                                INITAL.305   
      IF (NLONG.LT.0.OR.NLONG.GT.MG) THEN                                  INITAL.306   
         WRITE(6,6909)                                                     INITAL.307   
         CALL ABORT                                                        INITAL.308   
      ENDIF                                                                INITAL.309   
      IF (NCOEFF.LT.0.OR.NCOEFF.GT.NN) THEN                                INITAL.310   
         WRITE(6,6910)                                                     INITAL.311   
         CALL ABORT                                                        INITAL.312   
      ENDIF                                                                INITAL.313   
      IF (LTHPL(1).OR.LTHPL(2)) THEN                                       INITAL.314   
         WRITE(6,6911)                                                     INITAL.315   
         LTHPL(1)=.FALSE.                                                  SUNMOD.24    
         LTHPL(2)=.FALSE.                                                  SUNMOD.25    
      ENDIF                                                                INITAL.318   
      NWJC=0                                                               INITAL.319   
      DO 50 MP=1,MFP,MOCT                                                  INITAL.320   
      DO 50 JP=MP,NFP,MH                                                   INITAL.321   
   50 NWJC=NWJC+1                                                          INITAL.322   
      IF (NWJC.NE.NWJ2) THEN                                               INITAL.323   
         WRITE(6,6912) NWJ2,NWJC                                           INITAL.324   
         CALL ABORT                                                        INITAL.325   
      ENDIF                                                                INITAL.326   
C                                                                          INITAL.327   
C     Non-dimensionalise variables input as dimensional.                   INITAL.328   
C                                                                          INITAL.329   
      DO 60 L=1,NL                                                         INITAL.330   
   60 IF (DRAG(L).GT.0.) DRAG(L)=WW*CG*P0/(GA*PI2*DRAG(L))                 INITAL.331   
C                                                                          INITAL.332   
      DO 70 L=1,NL                                                         INITAL.333   
   70 TMEAN(L)=TMEAN(L)/CT                                                 INITAL.334   
C                                                                          INITAL.335   
      DO 80 L=1,NTHSF                                                      INITAL.336   
   80 THSURF(L)=THSURD(L)/CT                                               INITAL.337   
C                                                                          INITAL.338   
      CPHASE=CPHASE/360.                                                   INITAL.339   
C                                                                          INITAL.340   
      DELT=PI2/TSPD                                                        INITAL.341   
      DELT2=DELT+DELT                                                      INITAL.342   
      DELTSQ=DELT*DELT                                                     INITAL.343   
C                                                                          INITAL.344   
C     Set factors for time averaging every KOUNTD steps.                   INITAL.345   
C     Preset time averages of zonal mean aarays.                           INITAL.346   
C                                                                          INITAL.347   
      KLEN=KEND-KSTART                                                     INITAL.348   
      NRTAV=KLEN/KOUNTD                                                    INITAL.349   
      FTAV=2.                                                              INITAL.350   
      IF (NRTAV.GT.0) FTAV=1./FLOAT(NRTAV)                                 INITAL.351   
      LTAV=KEND.NE.KSTART                                                  INITAL.352   
      DO 90 I=1,IDDZ                                                       INITAL.353   
   90 DDZT(I)=0.                                                           INITAL.354   
C                                                                          INITAL.355   
C     Initialise output of spectral coefficients.                          INITAL.356   
C                                                                          INITAL.357   
      I=1                                                                  INITAL.358   
      DO 110 MP=1,MFP,MOCT                                                 INITAL.359   
      IF (MP.GT.NCOEFF) GOTO 120                                           INITAL.360   
      DO 100 JP=MP,NCOEFF,MH                                               INITAL.361   
  100 I=I+1                                                                INITAL.362   
  110 CONTINUE                                                             INITAL.363   
  120 INSPC=I-1                                                            INITAL.364   
      CALL WRSPI(Z(1),1)                                                   INITAL.365   
C                                                                          INITAL.366   
C     Constants for KE spectra.                                            INITAL.367   
C                                                                          INITAL.368   
      LNPIC=.TRUE.                                                         SUNMOD.26    
      NPTS4=0                                                              INITAL.370   
      RKEFAC=CG*P0/(2.*GA)                                                 INITAL.371   
      DO 130 I=1,NFP                                                       INITAL.372   
  130 RNWN(I)=FLOAT(I)                                                     INITAL.373   
C                                                                          INITAL.374   
C     Spectral arrays for Legendre transforms.                             INITAL.375   
C                                                                          INITAL.376   
      SQ(1)=0.                                                             INITAL.377   
      RSQ(1)=0.                                                            INITAL.378   
      DO 140 NP=2,NFPP                                                     INITAL.379   
      SQ(NP)=NP*(NP-1)                                                     INITAL.380   
  140 RSQ(NP)=1./SQ(NP)                                                    INITAL.381   
C                                                                          INITAL.382   
C     Array to calculate x-derivatives of Fourier coefficients.            INITAL.383   
C                                                                          INITAL.384   
      DO 150 I=1,IGL                                                       INITAL.385   
  150 CMPA(I)=0.                                                           INITAL.386   
      NROW=0                                                               INITAL.387   
CDIR$ IVDEP                                                                INITAL.388   
      DO 160 MP=1,MFP,MOCT                                                 INITAL.389   
      NROW=NROW+1                                                          INITAL.390   
      CMPA(NROW)=CMPLX(0.,FLOAT(MP-1))                                     INITAL.391   
      IF (NHEM.EQ.2) CMPA(NROW+IDL)=CMPA(NROW)                             INITAL.392   
  160 CONTINUE                                                             INITAL.393   
C                                                                          INITAL.394   
C     Auxiliary values required by FFT991.                                 INITAL.395   
C                                                                          INITAL.396   
      NTRWG=NLWG*NHEM                                                      INITAL.397   
      NTWG=(NTRWG-1)/NCRAY                                                 INITAL.398   
      NRSTWG=NTRWG-NCRAY*NTWG                                              INITAL.399   
      NTRNL=NL*NHEM                                                        INITAL.400   
      NTNL=(NTRNL-1)/NCRAY                                                 INITAL.401   
      NRSTNL=NTRNL-NCRAY*NTNL                                              INITAL.402   
      CALL FAX(IFAX,MG,3)                                                  INITAL.403   
      CALL FFTRIG(TRIG,MG,3)                                               INITAL.404   
C                                                                          INITAL.405   
C     Constants for output of grid point fields.                           INITAL.406   
C                                                                          INITAL.407   
      IF (NLAT.GT.0) INLAT=JG/NLAT                                         INITAL.408   
      IF (NLONG.GT.0) INLONG=MG/NLONG                                      INITAL.409   
C                                                                          INITAL.410   
C     Set up scratch files on SSD if required.                             INITAL.411   
C                                                                          INITAL.412   
      CALL INISSD(LCENTR)                                                  INITAL.413   
C                                                                          INITAL.414   
C     ----------------------------------------------------------------     INITAL.415   
C     Set up Gaussian latitudes and Legendre functions.                    INITAL.416   
C                                                                          INITAL.417   
      CALL INILAT                                                          INITAL.418   
      WRITE(6,6110) (ALAT(J),J=JG,1,-1)                                    INITAL.419   
C                                                                          INITAL.420   
C     ----------------------------------------------------------------     INITAL.421   
C     Set up sigma levels for vertical scheme.                             INITAL.422   
C                                                                          INITAL.423   
      CALL INILEV                                                          INITAL.424   
      WRITE(6,6120) SIGMAH                                                 INITAL.425   
      WRITE(6,6130) SIGMA                                                  INITAL.426   
C                                                                          INITAL.427   
C     Pressure levels for vertical interpolation and output.               INITAL.428   
C                                                                          INITAL.429   
      CALL INIPLV                                                          INITAL.430   
C                                                                          INITAL.431   
C     Derived arrays for vertical scheme.                                  INITAL.432   
C                                                                          INITAL.433   
      CALL INIVER                                                          INITAL.434   
C                                                                          INITAL.435   
C     Basic-state geopotential at full levels.                             INITAL.436   
C                                                                          INITAL.437   
      FAC=.001*CG/GA                                                       INITAL.438   
      IL=0                                                                 INITAL.439   
      DO 180 L=1,NL                                                        INITAL.440   
      HL=0.                                                                INITAL.441   
      DO 170 M=1,NL                                                        INITAL.442   
      IL=IL+1                                                              INITAL.443   
  170 HL=HL+G(IL)*TMEAN(M)                                                 INITAL.444   
  180 HEIGHT(L)=HL*FAC                                                     INITAL.445   
      WRITE(6,6140) (HEIGHT(L),L=1,NL)                                     INITAL.446   
C                                                                          INITAL.447   
C     Gravity wave speeds and time scheme matrix AQ.                       INITAL.448   
C                                                                          INITAL.449   
      IL=0                                                                 INITAL.450   
      INS=1                                                                INITAL.451   
      DO 210 L=1,NL                                                        INITAL.452   
      DO 200 M=1,NL                                                        INITAL.453   
      IN=INS                                                               INITAL.454   
      IL=IL+1                                                              INITAL.455   
      IM=M                                                                 INITAL.456   
      TAQ=TMEAN(L)*DSIGMA(M)                                               INITAL.457   
      DO 190 N=1,NL                                                        INITAL.458   
      TAQ=TAQ+G(IN)*TAU(IM)                                                INITAL.459   
      IN=IN+1                                                              INITAL.460   
  190 IM=IM+NL                                                             INITAL.461   
      AQ(IL)=TAQ                                                           INITAL.462   
  200 TBM1(IL)=TAQ                                                         INITAL.463   
  210 INS=INS+NL                                                           INITAL.464   
      CALL QREIG(TBM1,NL,NL,NL,CR,CI)                                      INITAL.465   
      DO 220 L=1,NL                                                        INITAL.466   
  220 CR(L)=CV*SQRT(CR(L))                                                 INITAL.467   
      WRITE(6,6150) (CR(L),L=1,NL)                                         INITAL.468   
C                                                                          INITAL.469   
C     ----------------------------------------------------------------     INITAL.470   
C     Initialise variables for parameterised processes.  Based on          INITAL.471   
C     parameterisations in simple GCM (SGCM), PDN=BGCM5,ID=UPLIB,ED=5.     INITAL.472   
C     Namelist INPHYS was read immediately after INPB.                     INITAL.473   
C     Derived values set up here require vertical levels from INILEV.      INITAL.474   
C                                                                          INITAL.475   
      WRITE(6,'('' '')')                                                   INITAL.476   
      WRITE(6,INPHYS)                                                      INITAL.477   
      IF (LDRY) THEN                                                       INITAL.478   
         WRITE(6,6200)                                                     INITAL.479   
      ELSE IF (LBL.OR.LVD.OR.LCR.OR.LLR.OR.LRD) THEN                       INITAL.480   
         WRITE(6,6210)                                                     INITAL.481   
      ELSE                                                                 INITAL.482   
         WRITE(6,6220)                                                     INITAL.483   
      ENDIF                                                                INITAL.484   
      IF (LBL) WRITE(6,6230) CD                                            INITAL.485   
      IF (LCR) WRITE(6,6240)                                               INITAL.486   
      IF (LLR) WRITE(6,6250)                                               INITAL.487   
      IF (LRD) WRITE(6,6260)                                               INITAL.488   
      IF (LVD) WRITE(6,6270) AKVV                                          INITAL.489   
      IF (LBL) READ(NCSURF) TSTAR,QSTAR                                    INITAL.490   
      ESCONB=CLATNT/RV                                                     INITAL.491   
      ESCONA=RD*EXP(ESCONB/273.15)*610.7/(RV*P0)                           INITAL.492   
      ESCONB=ESCONB/CT                                                     INITAL.493   
      BLCON=CD*GA*RADEA/(RD*CT*DSIGMA(NL))                                 INITAL.494   
      BLVAD=3./CV                                                          INITAL.495   
      CDIF=GA/(CV*WW)                                                      INITAL.496   
      CDIF=CDIF*CDIF                                                       INITAL.497   
      DO 230 L=1,NLM                                                       INITAL.498   
  230 FB(L)=CDIF*4.*SIGMAH(L)*SIGMAH(L)/(SIGMA(L+1)-SIGMA(L))              INITAL.499   
      AKVV=AKVV/(RADEA*CV)                                                 INITAL.500   
      IF (.NOT.LBL) THEN                                                   INITAL.501   
         DO 240 K=1,3                                                      INITAL.502   
         LPHGR(K)=.FALSE.                                                  SUNMOD.27    
  240    LPHPL(K)=.FALSE.                                                  SUNMOD.28    
      ENDIF                                                                INITAL.505   
      IF (.NOT.LCR) THEN                                                   INITAL.506   
         LPHGR(4)=.FALSE.                                                  SUNMOD.29    
         LPHPL(4)=.FALSE.                                                  SUNMOD.30    
      ENDIF                                                                INITAL.509   
      IF (.NOT.LLR) THEN                                                   INITAL.510   
         LPHGR(5)=.FALSE.                                                  SUNMOD.31    
         LPHPL(5)=.FALSE.                                                  SUNMOD.32    
      ENDIF                                                                INITAL.513   
      IF (.NOT.(LCR.AND.LLR)) THEN                                         INITAL.514   
         LPHGR(6)=.FALSE.                                                  SUNMOD.33    
         LPHPL(6)=.FALSE.                                                  SUNMOD.34    
      ENDIF                                                                INITAL.517   
C                                                                          INITAL.518   
C     ----------------------------------------------------------------     INITAL.519   
C     Initialise data transfer file (UTF).                                 INITAL.520   
C                                                                          INITAL.521   
      IF (KOUNTA.GT.0) CALL INIUTF(NAME,NPCA)                              INITAL.522   
C                                                                          INITAL.523   
C     Read and optionally output orography field.                          INITAL.528   
C                                                                          INITAL.529   
      CALL INIROG                                                          INITAL.530   
C                                                                          INITAL.531   
C     Copy $OUT output so far to fiche channel.                            INITAL.532   
C                                                                          INITAL.533   
      WRITE(6,'(''1'')')                                                   INITAL.534   
      REWIND 6                                                             INITAL.535   
C                                                                          INITAL.539   
      RETURN                                                               INITAL.540   
      END                                                                  INITAL.541   
C     ****************************************************************     INITAL.542   
*DECK INISSD                                                               INISSD.1     
      SUBROUTINE INISSD(LCENTR)                                            INISSD.2     
C                                                                          INISSD.3     
C     In unicos cannot explicitly place files on SSD since used as         UCOS.39    
C     ld-cache.  Instead files in temporary directory can be on SSD,       UCOS.40    
C     though residence of individual files is determined by system.        UCOS.41    
C     If LSSD=.F. leave all scratch files in current directory.            UCOS.42    
C     If LSSD=.T. open all scratch files in temporary directory.           UCOS.43    
C     Current directory is checked to avoid unnecessary opens.             UCOS.44    
C     Sizes of scratch files checked against SSD device size limit         UCOS.45    
C     and informative message printed (no abort as in COS).                UCOS.46    
C                                                                          INISSD.7     
*CALL PARAM1                                                               INISSD.8     
*CALL PARAM2                                                               INISSD.9     
*CALL BATS                                                                 INISSD.10    
*CALL COMIOC                                                               INISSD.11    
*CALL COMROG                                                               INISSD.12    
*CALL OUTCON                                                               INISSD.13    
*CALL PHYS                                                                 INISSD.14    
      CHARACTER LDEV*8,LCENTR*(*)                                          INISSD.15    
      SAVE LDEV                                                            INISSD.16    
C                                                                          INISSD.17    
      DATA NWGP,NWTHG,NWLEG,NWROGS,NWGEN,NWGDG,NWPLT2,NWPLT3/8*0/          INISSD.18    
      DATA LDEV/'*SSD    '/                                                INISSD.19    
C                                                                          INISSD.20    
 6000 FORMAT(/' SCRATCH FILES IN TEMPORARY DIRECTORY AND NEED'             UCOS.47    
     :       ,I6,' SECTORS, ',I10,' WORDS')                                UCOS.48    
 6010 FORMAT(/' SCRATCH FILES IN CURRENT DIRECTORY AND NEED'               UCOS.49    
     :       ,I6,' SECTORS, ',I10,' WORDS')                                UCOS.50    
 6020 FORMAT( ' (IF ALL OPTIONS SWITCHED ON AT CURRENT RESOLUTION,'        INISSD.25    
     :       ,' SIZE WOULD BE ',I6,' SECTORS, ',I10,' WORDS)')             INISSD.26    
 6030 FORMAT(' CURRENT DIRECTORY IS TEMPORARY : NO ACTION NEEDED')         UCOS.51    
 6900 FORMAT(/' SCRATCH FILES WOULD EXCEED SSD DEVICE SIZE LIMIT OF'       UCOS.52    
     :       ,I6,' SECTORS')                                               UCOS.53    
 6910 FORMAT(/' ***INISSD : ERROR OPENING UNIT WITH PATH ',A/)             UCOS.54    
C                                                                          INISSD.30    
C     Calculate total space required for all scratch files.                INISSD.31    
C     NW, NS are values with current switch settings.  MW, MS are          INISSD.32    
C     maximum values at current resolution if all options switched on.     INISSD.33    
C     NW is number of Cray words, NS is number of 512-word sectors.        INISSD.34    
C     Latter is used for the *SSD parameter on the COS job statement.      UCOS.55    
C                                                                          INISSD.36    
C     Channels NCGP(i) for model level / isobaric grid-point data.         INISSD.37    
      MWGP=((NSG-2+2)*IGD+4*IGC)*JG                                        INISSD.38    
      IF (LPC2.OR.LPC3.OR.LPC5.OR.LPC6) NWGP=MWGP                          INISSD.39    
C                                                                          INISSD.40    
C     Channel NCTHG for isentropic data.                                   INISSD.41    
      MWTHG=4*IDTHSF*JG                                                    INISSD.42    
      IF (LPC6) NWTHG=MWTHG                                                INISSD.43    
C                                                                          INISSD.44    
C     Channels NCLEG for Legendre Functions and NCROGS for orography.      INISSD.45    
      MWLEG=4*MJP*JG                                                       INISSD.46    
      MWROGS=IGC*JG                                                        INISSD.47    
      IF (JGL.EQ.1) THEN                                                   INISSD.48    
         NWLEG=MWLEG                                                       INISSD.49    
         IF (LROG) NWROGS=MWROGS                                           INISSD.50    
      ENDIF                                                                INISSD.51    
C                                                                          INISSD.52    
C     Channel NCGEN for global energetics time series.                     INISSD.53    
      NTIMES=NRTAV+1                                                       INISSD.54    
      IF (LTAV) NTIMES=NTIMES+1                                            INISSD.55    
      MWGEN=(2+NTERM5+3)*NTIMES                                            INISSD.56    
      IF (LPC5) NWGEN=MWGEN                                                INISSD.57    
C                                                                          INISSD.58    
C     Channel NCGDG for global surface diagnostics time series.            INISSD.59    
      NTIMES=(KEND-KBEGP)/KOUNTD                                           INISSD.60    
      MWGDG=(2+2*NPH)*NTIMES+2                                             INISSD.61    
      IF (LPC9.AND.KEND.GT.KBEGP) NWGDG=MWGDG                              INISSD.62    
C                                                                          INISSD.63    
C     Channels NCPLOT(2-3) for KE spectra scratch files.                   INISSD.64    
C     Following calc. is not exact but is max used: see LOUTE logic.       INISSD.65    
      IF (KOUNTE.GT.0) THEN                                                INISSD.66    
         NTIMES=1+(KEND-KSTART)/KOUNTE                                     INISSD.67    
      ELSE                                                                 INISSD.68    
         NTIMES=NPMAX4                                                     INISSD.69    
      ENDIF                                                                INISSD.70    
      NTRUNC=MIN0(NTIMES,NPMAX4)                                           INISSD.71    
C     Channel NCPLOT(2).                                                   INISSD.72    
      MWPLT2=NTIMES*(16+2*(NWW-1))+(16+4+NTRUNC)                           INISSD.73    
C     Channel NCPLOT(3).                                                   INISSD.74    
      NPTS=MIN0(NWW-1,21/MOCT)                                             INISSD.75    
      MWPLT3=NTRUNC*(1+NPTS)                                               INISSD.76    
      IF (KOUNTE.GT.0.AND.LSPPLT) THEN                                     INISSD.77    
         NWPLT2=MWPLT2                                                     INISSD.78    
         NWPLT3=MWPLT3                                                     INISSD.79    
      ENDIF                                                                INISSD.80    
C                                                                          INISSD.81    
      NW=NWGP+NWTHG+NWLEG+NWROGS+NWGEN+NWGDG+NWPLT2+NWPLT3                 INISSD.82    
      NS=(NW+511)/512                                                      INISSD.83    
      MW=MWGP+MWTHG+MWLEG+MWROGS+MWGEN+MWGDG+MWPLT2+MWPLT3                 INISSD.84    
      MS=(MW+511)/512                                                      INISSD.85    
C                                                                          INISSD.86    
C     Check whether explicit opens are needed : only if SSD requested,     UCOS.56    
C     if at RAL and if working directory is not temporary.                 UCOS.57    
C                                                                          INISSD.88    
      IF (LSSD.AND.(LCENTR.EQ.'RAL')) THEN                                 INISSD.89    
         WRITE(6,6000) NS,NW                                               UCOS.58    
         WRITE(6,6020) MS,MW                                               INISSD.91    
         IF (CPTHWD.EQ.CPTHTD) THEN                                        UCOS.59    
            WRITE(6,6030)                                                  UCOS.60    
            RETURN                                                         UCOS.61    
         ENDIF                                                             UCOS.62    
      ELSE                                                                 INISSD.92    
         WRITE(6,6010) NS,NW                                               INISSD.93    
         WRITE(6,6020) MS,MW                                               INISSD.94    
         RETURN                                                            INISSD.95    
      ENDIF                                                                INISSD.96    
C                                                                          INISSD.97    
C     Check total size of scratch files against SSD device limit of        UCOS.63    
C     NSMAX * 512word sectors.  Message is for information only in         UCOS.64    
C     unicos.  If largest files are wanted on SSD, try omitting            UCOS.65    
C     channels not used (output types not switched on), or try omitting    INISSD.101   
C     in order: NCPLOT(2-3), NCGEN, NCGDG, NCROGG, NCLEG, NCTHG,           INISSD.102   
C     then finally some of NCGP(1-NGP).                                    INISSD.103   
C                                                                          INISSD.104   
      NSMAX=128000000/512                                                  UCOS.66    
      IF (NS.GT.NSMAX) WRITE(6,6900) NSMAX                                 UCOS.67    
C                                                                          INISSD.110   
C     Assign individual channels.                                          INISSD.111   
C                                                                          INISSD.112   
      IF (LPC2.OR.LPC3.OR.LPC5.OR.LPC6) THEN                               INISSD.113   
         DO 10 I=1,NGP                                                     INISSD.114   
         OPEN(NCGP(I),FILE=CPTHTD(1:NLENTD)//'/'//LCHAN                    UCOS.68    
     :       ,FORM='UNFORMATTED',ERR=900)                                  UCOS.69    
   10    CONTINUE                                                          INISSD.117   
      ENDIF                                                                INISSD.118   
C                                                                          INISSD.119   
      IF (LPC6) THEN                                                       INISSD.120   
         OPEN(NCTHG,FILE=CPTHTD(1:NLENTD)//'/'//LCHAN                      UCOS.70    
     :       ,FORM='UNFORMATTED',ERR=900)                                  UCOS.71    
      ENDIF                                                                INISSD.123   
C                                                                          INISSD.124   
      IF (JGL.EQ.1) THEN                                                   INISSD.125   
         OPEN(NCLEG,FILE=CPTHTD(1:NLENTD)//'/'//LCHAN                      UCOS.72    
     :       ,FORM='UNFORMATTED',ERR=900)                                  UCOS.73    
         IF (LROG) THEN                                                    INISSD.128   
            OPEN(NCROGG,FILE=CPTHTD(1:NLENTD)//'/'//LCHAN                  UCOS.74    
     :          ,FORM='UNFORMATTED',ERR=900)                               UCOS.75    
         ENDIF                                                             INISSD.131   
      ENDIF                                                                INISSD.132   
C                                                                          INISSD.133   
      IF (LPC5) THEN                                                       INISSD.134   
         OPEN(NCGEN,FILE=CPTHTD(1:NLENTD)//'/'//LCHAN                      UCOS.76    
     :       ,FORM='UNFORMATTED',ERR=900)                                  UCOS.77    
      ENDIF                                                                INISSD.137   
C                                                                          INISSD.138   
      IF (LPC9.AND.KEND.GT.KBEGP) THEN                                     INISSD.139   
         OPEN(NCGDG,FILE=CPTHTD(1:NLENTD)//'/'//LCHAN                      UCOS.78    
     :       ,FORM='UNFORMATTED',ERR=900)                                  UCOS.79    
      ENDIF                                                                INISSD.142   
C                                                                          INISSD.143   
      IF (KOUNTE.GT.0.AND.LSPPLT) THEN                                     INISSD.144   
         OPEN(NCPLOT(2),FILE=CPTHTD(1:NLENTD)//'/'//LCHAN                  UCOS.80    
     :       ,FORM='UNFORMATTED',ERR=900)                                  UCOS.81    
         OPEN(NCPLOT(3),FILE=CPTHTD(1:NLENTD)//'/'//LCHAN                  UCOS.82    
     :       ,FORM='UNFORMATTED',ERR=900)                                  UCOS.83    
      ENDIF                                                                INISSD.149   
C                                                                          INISSD.150   
      RETURN                                                               INISSD.151   
C                                                                          UCOS.84    
C     Error trapping : print message and return if OPEN fails.             UCOS.85    
C                                                                          UCOS.86    
  900 WRITE(6,6910) CPTHTD(1:NLENTD)//'/'//LCHAN                           UCOS.87    
      RETURN                                                               UCOS.88    
C                                                                          UCOS.89    
      END                                                                  INISSD.152   
C     ****************************************************************     INISSD.153   
*DECK INILAT                                                               INILAT.1     
      SUBROUTINE INILAT                                                    INILAT.2     
C                                                                          INILAT.3     
C     Set up Gaussian latitudes and Legendre functions.                    INILAT.4     
C     Subroutine GWTLT calculates Gaussian weights and latitudes.          INILAT.5     
C     Subroutine LGNDRE calculates Associated Legendre Functions (ALP)     INILAT.6     
C     and their derivatives (DALP).                                        INILAT.7     
C                                                                          INILAT.8     
*CALL PARAM1                                                               INILAT.9     
*CALL PARAM2                                                               INILAT.10    
*CALL BATS                                                                 INILAT.11    
*CALL BLANK                                                                INILAT.12    
*CALL COMIOC                                                               INILAT.13    
*CALL LEGAU                                                                INILAT.14    
      IF (JGL.EQ.1)  JINC=0.                                               INILAT.15    
      IF (JGL.EQ.JG) JINC=1                                                INILAT.16    
C                                                                          INILAT.17    
      JL=1                                                                 INILAT.18    
      DO 20 J=1,JG                                                         INILAT.19    
      JH=J                                                                 INILAT.20    
      CALL GWTLT(SIJ,WEIGHT,J,JG)                                          INILAT.21    
      SI(J)=SIJ                                                            INILAT.22    
      SISQ(J)=SI(J)*SI(J)                                                  INILAT.23    
      CSSQ(J)=1.-SISQ(J)                                                   INILAT.24    
      CS(J)=SQRT(CSSQ(J))                                                  INILAT.25    
      GWT(J)=WEIGHT/FLOAT(NHEM)                                            INILAT.26    
      CALL LGNDRE                                                          INILAT.27    
      IP=0                                                                 INILAT.28    
      DO 10 MP=1,MFP,MOCT                                                  INILAT.29    
      N=MP-1                                                               INILAT.30    
      NMAX=MP+((NFP-MP)/2)*2+1                                             INILAT.31    
      DO 10 JP=MP,NMAX                                                     INILAT.32    
      IP=IP+1                                                              INILAT.33    
      N=N+1                                                                INILAT.34    
      RLP(IP,JL)=-RSQ(N)*ALP(IP,JL)                                        INILAT.35    
      RDLP(IP,JL)=-RSQ(N)*DALP(IP,JL)                                      INILAT.36    
   10 CONTINUE                                                             INILAT.37    
      IF (JGL.EQ.1) WRITE(NCLEG) ALP,DALP,RLP,RDLP                         INILAT.38    
   20 JL=JL+JINC                                                           INILAT.39    
C                                                                          INILAT.40    
      DO 30 J=1,JG                                                         INILAT.41    
      SECSQ(J)=1./CSSQ(J)                                                  INILAT.42    
      ALAT(J)=ATAN(SI(J)/CS(J))*180./PI                                    INILAT.43    
      AW(J)=GWT(J)*FLOAT(NHEM)*2.*SECSQ(J)                                 INILAT.44    
   30 CONTINUE                                                             INILAT.45    
      IF (NHEM.EQ.2) THEN                                                  INILAT.46    
CDIR$ IVDEP                                                                INILAT.47    
         DO 40 J=1,JG                                                      INILAT.48    
         SI(JGGP-J)=-SI(J)                                                 INILAT.49    
         CS(JGGP-J)=CS(J)                                                  INILAT.50    
         SISQ(JGGP-J)=SISQ(J)                                              INILAT.51    
         CSSQ(JGGP-J)=CSSQ(J)                                              INILAT.52    
         SECSQ(JGGP-J)=SECSQ(J)                                            INILAT.53    
         ALAT(JGGP-J)=-ALAT(J)                                             INILAT.54    
         GWT(JGGP-J)=GWT(J)                                                INILAT.55    
         AW(JGGP-J)=AW(J)                                                  INILAT.56    
   40    CONTINUE                                                          INILAT.57    
      ENDIF                                                                INILAT.58    
C                                                                          INILAT.59    
C     Set up factors for extrapolation at poles.                           INILAT.60    
C     Used in routine FLUX for y-derivatives of dynamical fields.          INILAT.61    
C                                                                          INILAT.62    
      EXN1=(SI(3)-SI(1))/(SI(3)-SI(2))                                     INILAT.63    
      EXN2=(SI(2)-SI(1))/(SI(3)-SI(2))                                     INILAT.64    
      EXS1=(SI(JGGM2)-SI(JGG))/(SI(JGGM2)-SI(JGGM))                        INILAT.65    
      EXS2=(SI(JGGM)-SI(JGG))/(SI(JGGM2)-SI(JGGM))                         INILAT.66    
C                                                                          INILAT.67    
C     Set up factors for extrapolation/interpolation to equator.           INILAT.68    
C     Used for plotting and dumping lat-long fields.                       INILAT.69    
C                                                                          INILAT.70    
      IF (NHEM.EQ.1) THEN                                                  INILAT.71    
         EXE1=ALAT(JG)*ALAT(JG)                                            INILAT.72    
         EXE2=ALAT(JG-1)*ALAT(JG-1)                                        INILAT.73    
      ELSE                                                                 INILAT.74    
         EXE1=ALAT(JG)                                                     INILAT.75    
         EXE2=ALAT(JG-1)                                                   INILAT.76    
      ENDIF                                                                INILAT.77    
      EXE3=1./(EXE2-EXE1)                                                  INILAT.78    
C                                                                          INILAT.79    
      RETURN                                                               INILAT.80    
      END                                                                  INILAT.81    
C     ****************************************************************     INILAT.82    
*DECK LGNDRE                                                               LGNDRE.1     
      SUBROUTINE LGNDRE                                                    LGNDRE.2     
C                                                                          LGNDRE.3     
C     Calculate Associated Legendre Functions at current latitude          LGNDRE.4     
C     in array ALP and their meridional derivatives in array DALP.         LGNDRE.5     
C          ALP = Pnm,     DALP = (1-mu**2)dPnm/dmu.                        LGNDRE.6     
C     Spectral truncation is jagged triangular at total wavenumber         LGNDRE.7     
C     NN (defined in parameter statement), with equal numbers of           LGNDRE.8     
C     even and odd functions for each zonal wavenumber.                    LGNDRE.9     
C     Includes zonal wavenumbers 0, MOCT, 2*MOCT,... to maximum NN-1.      LGNDRE.10    
C     Uses latitude counter JH in common LEGAU as the subscript            LGNDRE.11    
C     of the SI array for mu=sin(lat) and CS for cos(lat).                 LGNDRE.12    
C                                                                          LGNDRE.13    
*CALL PARAM1                                                               LGNDRE.14    
*CALL PARAM2                                                               LGNDRE.15    
*CALL BLANK                                                                LGNDRE.16    
*CALL LEGAU                                                                LGNDRE.17    
      LM=2                                                                 LGNDRE.18    
      ALP(1,JL)=SQRT(.5)                                                   LGNDRE.19    
      F1M=SQRT(1.5)                                                        LGNDRE.20    
      ALP(2,JL)=F1M*SI(JH)                                                 LGNDRE.21    
      DALP(1,JL)=0.                                                        LGNDRE.22    
      DO 40 M1=1,MFP                                                       LGNDRE.23    
      M=M1-1                                                               LGNDRE.24    
      AM=M                                                                 LGNDRE.25    
      A2M=M+M                                                              LGNDRE.26    
      E2=SQRT(A2M+3.)                                                      LGNDRE.27    
      IF (M.EQ.0) GOTO 10                                                  LGNDRE.28    
      F2M=-F1M*CS(JH)/SQRT(A2M)                                            LGNDRE.29    
      F1M=F2M*E2                                                           LGNDRE.30    
      IF (M.NE.MMO) GOTO 40                                                LGNDRE.31    
      LM=LM+1                                                              LGNDRE.32    
      ALP(LM,JL)=F2M                                                       LGNDRE.33    
      LM=LM+1                                                              LGNDRE.34    
      ALP(LM,JL)=F1M*SI(JH)                                                LGNDRE.35    
      DALP(LM-1,JL)=-AM*ALP(LM,JL)/E2                                      LGNDRE.36    
   10 M2=M+2                                                               LGNDRE.37    
      MMO=M+MOCT                                                           LGNDRE.38    
      JFM=((NFP-M1)/2)*2+M2-1                                              LGNDRE.39    
      IF (JFM.LT.M2) GOTO 30                                               LGNDRE.40    
      K=LM-M2+1                                                            LGNDRE.41    
      AMSQ=AM*AM                                                           LGNDRE.42    
      DO 20 N=M2,JFM                                                       LGNDRE.43    
      AN=N                                                                 LGNDRE.44    
      AN2=N*N                                                              LGNDRE.45    
      ANM2=(N-1)*(N-1)                                                     LGNDRE.46    
      E1=SQRT((ANM2-AMSQ)/(4.*ANM2-1.))                                    LGNDRE.47    
      E2=SQRT((4.*AN2-1.)/(AN2-AMSQ))                                      LGNDRE.48    
      ALP(K+N,JL)=E2*(SI(JH)*ALP(K+N-1,JL)-E1*ALP(K+N-2,JL))               LGNDRE.49    
      DALP(K+N-1,JL)= (1.-AN)*ALP(K+N,JL)/E2+AN*E1*ALP(K+N-2,JL)           LGNDRE.50    
   20 CONTINUE                                                             LGNDRE.51    
      LM=LM+JFM-M2+1                                                       LGNDRE.52    
   30 CONTINUE                                                             LGNDRE.53    
      DALP(LM,JL)=-AN*SI(JH)*ALP(LM,JL)+(AN+AN+1.)*ALP(LM-1,JL)/E2         LGNDRE.54    
   40 CONTINUE                                                             LGNDRE.55    
C                                                                          LGNDRE.56    
      RETURN                                                               LGNDRE.57    
      END                                                                  LGNDRE.58    
C     ****************************************************************     LGNDRE.59    
*DECK INILEV                                                               INILEV.1     
      SUBROUTINE INILEV                                                    INILEV.2     
C                                                                          INILEV.3     
C     Set up sigma levels for vertical scheme.                             INILEV.4     
C     Equispaced for NL <= 5.                                              INILEV.5     
C                                                                          INILEV.6     
*CALL PARAM1                                                               INILEV.7     
*CALL PARAM2                                                               INILEV.8     
*CALL BLANK                                                                INILEV.9     
      STP=1./FLOAT(NL)                                                     INILEV.10    
      IF (NL.LE.5) THEN                                                    INILEV.11    
         DO 10 L=1,NLM                                                     INILEV.12    
   10    SIGMAH(L)=L*STP                                                   INILEV.13    
      ELSE                                                                 INILEV.14    
         T1=(.9375/.94-1.25)/(.9375*(SQRT(.9375)-1.))                      INILEV.15    
         T2=4.+T1                                                          INILEV.16    
         P=0.                                                              INILEV.17    
         DO 20 L=1,NLM                                                     INILEV.18    
         P=P+STP                                                           INILEV.19    
         VV=P/(5.-T2*P+T1*(P**1.5))                                        INILEV.20    
         VV=VV*(2.-P)*(1.+.25*SIN(PI2*(P**.6)))                            INILEV.21    
         SIGMAH(L)=VV                                                      INILEV.22    
   20    CONTINUE                                                          INILEV.23    
      ENDIF                                                                INILEV.24    
C                                                                          INILEV.25    
      S1=0.                                                                INILEV.26    
      DO 30 L=1,NLM                                                        INILEV.27    
      S2=SIGMAH(L)                                                         INILEV.28    
      DSIGMA(L)=S2-S1                                                      INILEV.29    
      SIGMA(L)=.5*(S2+S1)                                                  INILEV.30    
   30 S1=S2                                                                INILEV.31    
      DSIGMA(NL)=1.-SIGMAH(NLM)                                            INILEV.32    
      SIGMA(NL)=.5*(1.+SIGMAH(NLM))                                        INILEV.33    
C                                                                          INILEV.34    
      DO 40 L=1,NL                                                         INILEV.35    
      SIGMAK(L)=SIGMA(L)**(-AKAP)                                          INILEV.36    
      SIGM1K(L)=SIGMAK(L)/SIGMA(L)                                         INILEV.37    
      RDSIG(L)=.5/DSIGMA(L)                                                INILEV.38    
   40 CONTINUE                                                             INILEV.39    
C                                                                          INILEV.40    
      RETURN                                                               INILEV.41    
      END                                                                  INILEV.42    
C     ****************************************************************     INILEV.43    
*DECK INIPLV                                                               INIPLV.1     
      SUBROUTINE INIPLV                                                    INIPLV.2     
C                                                                          INIPLV.3     
C     Set up pressure levels for vertical interpolation.                   INIPLV.4     
C     Default in INPB gives NL levels with p(l) = sigma(l) * p0.           INIPLV.5     
C     PPR array is non-dimensional.  PLOUT is in mb for titles.            INIPLV.6     
C     Check and modify switches for interpolation and output streams.      INIPLV.7     
C                                                                          INIPLV.8     
*CALL PARAM1                                                               INIPLV.9     
*CALL PARAM2                                                               INIPLV.10    
*CALL BLANK                                                                INIPLV.11    
*CALL COMPRL                                                               INIPLV.12    
*CALL OUTCON                                                               INIPLV.13    
 6000 FORMAT(/' OUTPUT PRESSURE LEVELS (MB)'/(1X,15F7.1))                  INIPLV.14    
 6010 FORMAT(/' FIELDS INTERPOLATED TO PRESSURE FOR LAT-LONG OUTPUT')      INIPLV.15    
 6020 FORMAT(/' FIELDS INTERPOLATED TO PRESSURE FOR ZONAL/GLOBAL DIAGS')   INIPLV.16    
 6900 FORMAT(/' ***ABORT IN INIPLV: MORE THAN NL PRESSURE LEVELS'          INIPLV.17    
     :       ,' REQUESTED - NOT ALLOWED')                                  INIPLV.18    
 6910 FORMAT(/' ***WARNING: ZONAL AVERAGES CANNOT BE CALCULATED USING'     INIPLV.19    
     :       ,' ARBITRARY PRESSURE LEVELS - LPC3 SWITCHED OFF')            INIPLV.20    
 6920 FORMAT(/' ***WARNING: GLOBAL DIAGS CANNOT BE CALCULATED USING'       INIPLV.21    
     :       ,' ARBITRARY PRESSURE LEVELS - LPC5 SWITCHED OFF')            INIPLV.22    
 6930 FORMAT(/' ***ABORT IN INIPLV: PRESSURE LEVELS IN PLOUT ARRAY IN'     INIPLV.23    
     :       ,' NAMELIST INPB MUST BE IN INCREASING ORDER')                INIPLV.24    
 6940 FORMAT(/' ***ABORT IN INIPLV: OUTPUT PRESSURE LEVEL',F10.1           INIPLV.25    
     :       ,' IS OUTSIDE VALID RANGE')                                   INIPLV.26    
 6950 FORMAT(/' ***WARNING : NO VERTICAL INTERPOLATION OF ZONAL MEAN'      INIPLV.27    
     :       ,' FIELDS TO PRESSURE LEVELS :'                               INIPLV.28    
     :       /' GLOBAL DIAGNOSTICS IN GDIAG INCORRECT, SO SWITCHED OFF')   INIPLV.29    
 6960 FORMAT(/' ***WARNING : MODEL LEVEL FIELDS INTERPOLATED TO'           INIPLV.30    
     :       ,' PRESSURE LEVELS IN GRMULT (LINTP2=.TRUE.) :'               SUNMOD.35    
     :       /' ZONAL MEAN FIELDS MUST BE ISOBARIC : LINTP3 RESET =.TRUE   SUNMOD.36    
     :.')                                                                  SUNMOD.37    
C                                                                          INIPLV.33    
      IF (.NOT.(LINTP2.OR.LINTP3)) GOTO 100                                INIPLV.34    
C                                                                          INIPLV.35    
      NLTEMP=NLPR                                                          INIPLV.36    
      IF (NLTEMP.GT.NL) THEN                                               INIPLV.37    
         WRITE(6,6900)                                                     INIPLV.38    
         CALL ABORT                                                        INIPLV.39    
      ELSE IF (NLTEMP.GT.0) THEN                                           INIPLV.40    
         LINTP3=.FALSE.                                                    SUNMOD.38    
         IF (LPC3) THEN                                                    INIPLV.42    
            LPC3=.FALSE.                                                   SUNMOD.39    
            WRITE(6,6910)                                                  INIPLV.44    
         ENDIF                                                             INIPLV.45    
         IF (LPC5) THEN                                                    INIPLV.46    
            LPC5=.FALSE.                                                   SUNMOD.40    
            WRITE(6,6920)                                                  INIPLV.48    
         ENDIF                                                             INIPLV.49    
         WRITE(6,6000) (PLOUT(L),L=1,NLTEMP)                               INIPLV.50    
         DO 10 L=2,NLTEMP                                                  INIPLV.51    
         IF (PLOUT(L).LT.PLOUT(L-1)) THEN                                  INIPLV.52    
            WRITE(6,6930)                                                  INIPLV.53    
            CALL ABORT                                                     INIPLV.54    
         ENDIF                                                             INIPLV.55    
   10    CONTINUE                                                          INIPLV.56    
         DO 20 L=1,NLTEMP                                                  INIPLV.57    
         PPR(L)=PLOUT(L)*100./P0                                           INIPLV.58    
         IF (PPR(L).LE.0..OR.PPR(L).GT.1.2) THEN                           INIPLV.59    
            WRITE(6,6940) PLOUT(L)                                         INIPLV.60    
            CALL ABORT                                                     INIPLV.61    
         ENDIF                                                             INIPLV.62    
   20    CONTINUE                                                          INIPLV.63    
      ELSE IF (NLTEMP.LE.0) THEN                                           INIPLV.64    
         NLPR=NL                                                           INIPLV.65    
         DO 30 L=1,NLPR                                                    INIPLV.66    
         PPR(L)=SIGMA(L)                                                   INIPLV.67    
   30    PLOUT(L)=PPR(L)*P0/100.                                           INIPLV.68    
         WRITE(6,6000) (PLOUT(L),L=1,NL)                                   INIPLV.69    
      ENDIF                                                                INIPLV.70    
C                                                                          INIPLV.71    
  100 CONTINUE                                                             INIPLV.72    
      IF ((.NOT.(LINTP2.OR.LINTP3)).AND.LPC5) THEN                         INIPLV.73    
         LPC5=.FALSE.                                                      SUNMOD.41    
         WRITE(6,6950)                                                     INIPLV.75    
      ENDIF                                                                INIPLV.76    
      IF (LINTP2.AND.(.NOT.LINTP3).AND.(LPC3.OR.LPC5)) THEN                INIPLV.77    
         LINTP3=.TRUE.                                                     SUNMOD.42    
         WRITE(6,6960)                                                     INIPLV.79    
      ENDIF                                                                INIPLV.80    
C                                                                          INIPLV.81    
      IF (LINTP2.AND.LPC2) WRITE(6,6010)                                   INIPLV.82    
      IF (LINTP3.AND.(LPC3.OR.LPC5)) WRITE(6,6020)                         INIPLV.83    
C                                                                          INIPLV.84    
      RETURN                                                               INIPLV.85    
      END                                                                  INIPLV.86    
C     ****************************************************************     INIPLV.87    
*DECK INIVER                                                               INIVER.1     
      SUBROUTINE INIVER                                                    INIVER.2     
C                                                                          INIVER.3     
C     Set up derived arrays for vertical scheme.                           INIVER.4     
C                                                                          INIVER.5     
*CALL PARAM1                                                               INIVER.6     
*CALL PARAM2                                                               INIVER.7     
*CALL BATS                                                                 INIVER.8     
*CALL BLANK                                                                INIVER.9     
C                                                                          INIVER.10    
C     G and ALPHA matrices, TKP and T01S2 vectors.                         INIVER.11    
C     This value of S1, used in setting ALPHA(1), is irrelevant            INIVER.12    
C     in the angular momentum conserving ECMWF scheme.                     INIVER.13    
C                                                                          INIVER.14    
      S1=LOG(SIGMA(1)*SIGMA(1)/SIGMAH(1))                                  SUNMOD.88    
      T0M=TMEAN(1)                                                         INIVER.16    
      IG=1                                                                 INIVER.17    
      DO 10 L=1,NLM                                                        INIVER.18    
      LP=L+1                                                               INIVER.19    
      S2=LOG(SIGMAH(L))                                                    SUNMOD.89    
      T0P=TMEAN(LP)                                                        INIVER.21    
      IG=IG+NL                                                             INIVER.22    
      G(IG)=0.                                                             INIVER.23    
      T01S2(L)=T0P-T0M                                                     INIVER.24    
      ALPHA(L)=S2-S1                                                       INIVER.25    
      TKP(L)=AKAP*T0M                                                      INIVER.26    
      T0M=T0P                                                              INIVER.27    
   10 S1=S2                                                                INIVER.28    
      ALPHA(NL)=-S1                                                        INIVER.29    
      TKP(NL)=AKAP*T0M                                                     INIVER.30    
      G(1)=1.0                                                             INIVER.31    
      DO 40 J=2,NL                                                         INIVER.32    
      ALJ=ALPHA(J)                                                         INIVER.33    
      IG=J                                                                 INIVER.34    
      LIM=J-1                                                              INIVER.35    
      DO 20 I=1,LIM                                                        INIVER.36    
      G(IG)=ALJ                                                            INIVER.37    
   20 IG=IG+NL                                                             INIVER.38    
      G(IG)=1.0-ALJ*SIGMAH(LIM)/DSIGMA(J)                                  INIVER.39    
      IF (J.EQ.NL) GOTO 40                                                 INIVER.40    
      LIM=LIM+2                                                            INIVER.41    
      DO 30 I=LIM,NL                                                       INIVER.42    
      IG=IG+NL                                                             INIVER.43    
   30 G(IG)=0.                                                             INIVER.44    
   40 CONTINUE                                                             INIVER.45    
C                                                                          INIVER.46    
C     C matrix.                                                            INIVER.47    
C                                                                          INIVER.48    
      IC=-1                                                                INIVER.49    
      DO 50 I=1,NL                                                         INIVER.50    
      IC=IC+1                                                              INIVER.51    
      JC=IC*NLP                                                            INIVER.52    
      JCC=JC-NLM                                                           INIVER.53    
      DO 50 J=I,NL                                                         INIVER.54    
      JC=JC+1                                                              INIVER.55    
      JCC=JCC+NL                                                           INIVER.56    
   50 C(JCC)=G(JC)*DSIGMA(I)/DSIGMA(J)                                     INIVER.57    
C                                                                          INIVER.58    
C     TAU vector.                                                          INIVER.59    
C                                                                          INIVER.60    
      TT01S2=T01S2(1)                                                      INIVER.61    
      TAU(1)=0.5*TT01S2*(SIGMAH(1)-1.0)+TKP(1)*C(1)                        INIVER.62    
      DO 60 L=2,NL                                                         INIVER.63    
   60 TAU(L)=0.5*TT01S2*DSIGMA(L)                                          INIVER.64    
      SIG=SIGMAH(1)                                                        INIVER.65    
      IT=NL                                                                INIVER.66    
      DO 140 L=2,NL                                                        INIVER.67    
      TTKP=TKP(L)                                                          INIVER.68    
      TTM=TT01S2                                                           INIVER.69    
      SIGM=SIG                                                             INIVER.70    
      IF (L-NL) 70,80,80                                                   INIVER.71    
   70 TT01S2=T01S2(L)                                                      INIVER.72    
      SIG=SIGMAH(L)                                                        INIVER.73    
   80 RDSIGL=RDSIG(L)                                                      INIVER.74    
      DO 130 M=1,NL                                                        INIVER.75    
      IT=IT+1                                                              INIVER.76    
      IF (M-L) 90,100,110                                                  INIVER.77    
   90 TM=1.                                                                INIVER.78    
      TMM=1.                                                               INIVER.79    
      GOTO 120                                                             INIVER.80    
  100 TM=1.                                                                INIVER.81    
      TMM=0.                                                               INIVER.82    
      GOTO 120                                                             INIVER.83    
  110 TM=0.                                                                INIVER.84    
      TMM=0.                                                               INIVER.85    
  120 TTAU=TTM*(SIGM-TMM)                                                  INIVER.86    
      IF (L.LT.NL) TTAU=TTAU+TT01S2*(SIG-TM)                               INIVER.87    
      TTAU=TTAU*RDSIGL*DSIGMA(M)                                           INIVER.88    
      IF (M.LE.L) TTAU=TTAU+TTKP*C(IT)                                     INIVER.89    
  130 TAU(IT)=TTAU                                                         INIVER.90    
  140 CONTINUE                                                             INIVER.91    
C                                                                          INIVER.92    
C     RGG matrix for vertical derivatives:                                 INIVER.93    
C     d()/dln(sigma) = (sigma)d()/d(sigma).                                INIVER.94    
C                                                                          INIVER.95    
      IL=0                                                                 INIVER.96    
      DO 150 L=1,NL                                                        INIVER.97    
      RGVAL=SIGMA(L)*RDSIG(L)                                              INIVER.98    
      DO 150 M=1,NL                                                        INIVER.99    
      IL=IL+1                                                              INIVER.100   
      RGG(IL)=0.                                                           INIVER.101   
      IF (M.EQ.L-1) RGG(IL)=-RGVAL                                         INIVER.102   
      IF (M.EQ.L+1) RGG(IL)=RGVAL                                          INIVER.103   
  150 CONTINUE                                                             INIVER.104   
      DA=SIGMA(1)                                                          INIVER.105   
      DB=SIGMA(2)-DA                                                       INIVER.106   
      DC=SIGMA(3)-SIGMA(2)                                                 INIVER.107   
      DD=DC+DB                                                             INIVER.108   
      RGG(1)=-DA*(DD+DB)/(DB*DD)                                           INIVER.109   
      RGG(2)=DA*DD/(DB*DC)                                                 INIVER.110   
      RGG(3)=-DA*DB/(DC*DD)                                                INIVER.111   
      DA=SIGMA(NL)                                                         INIVER.112   
      DD=SIGMA(NL-1)                                                       INIVER.113   
      DB=DA-DD                                                             INIVER.114   
      DC=DD-SIGMA(NL-2)                                                    INIVER.115   
      DD=DC+DB                                                             INIVER.116   
      RGG(NL2)=DA*(DD+DB)/(DB*DD)                                          INIVER.117   
      RGG(NL2-1)=-DA*DD/(DB*DC)                                            INIVER.118   
      RGG(NL2-2)=DA*DB/(DC*DD)                                             INIVER.119   
C                                                                          INIVER.120   
      RETURN                                                               INIVER.121   
      END                                                                  INIVER.122   
C     ****************************************************************     INIVER.123   
*DECK INIROG                                                               INIROG.1     
      SUBROUTINE INIROG                                                    INIROG.2     
C                                                                          INIROG.3     
C     Read orography from channel NCROGS and optionally print/plot/dump.   BUGS5.1     
C     If JGL=1, write JG records to scratch channel NCROGG.                BUGS5.2     
C     If JGL=JG store all latitudes in /GRIDP/.                            INIROG.6     
C     NB.  Array GPV is equivalenced to spectral data in /SPECTR/.         INIROG.7     
C                                                                          INIROG.8     
*CALL PARAM1                                                               INIROG.9     
*CALL PARAM2                                                               INIROG.10    
*CALL BLANK                                                                INIROG.11    
*CALL COMFFT                                                               INIROG.12    
*CALL COMIOC                                                               INIROG.13    
*CALL COMMSK                                                               INIROG.14    
*CALL COMPRL                                                               INIROG.15    
*CALL COMROG                                                               INIROG.16    
*CALL GRIDP                                                                INIROG.18    
*CALL LEGAU                                                                INIROG.19    
*CALL OUTCON                                                               INIROG.20    
*CALL SPECTR                                                               INIROG.21    
      REAL GPV(IGC*JG),EGSG(IGC*JGL)                                       INIROG.22    
      EQUIVALENCE (GPV(1),Z(1)),(EGSG(1),GSG(1,1))                         INIROG.23    
      LOGICAL LAORF                                                        INIROG.24    
      CHARACTER*50 NAME                                                    INIROG.25    
C                                                                          INIROG.26    
      DATA NAME /'OROGRAPHIC HEIGHT                        METRES   '/     INIROG.27    
C                                                                          INIROG.28    
 6000 FORMAT(/' OROGRAPHY INCLUDED IN DIAGNOSTICS')                        INIROG.29    
 6010 FORMAT(/' ***INIROG: LAT-LONG OROGRAPHIC MASK NOT NEEDED:'           INIROG.30    
     :       ,' SWITCHED OFF')                                             INIROG.31    
 6020 FORMAT(/' ***INIROG: ZONAL MEAN OROGRAPHIC MASK NOT NEEDED:'         INIROG.32    
     :       ,' SWITCHED OFF')                                             INIROG.33    
 6030 FORMAT(/' OROGRAPHIC MASK PLOTTED ON ISOBARIC LAT-LONG FIELDS')      INIROG.34    
 6040 FORMAT(/' OROGRAPHIC MASK PLOTTED ON ISOBARIC ZONAL SECTIONS')       INIROG.35    
C                                                                          INIROG.36    
C     Preset spectral and grid point orography to zero.                    INIROG.37    
C                                                                          INIROG.38    
      DO 10 I=1,IGA                                                        INIROG.39    
   10 GS(I)=(0.,0.)                                                        INIROG.40    
      DO 20 I=1,IGC*JGL                                                    INIROG.41    
   20 EGSG(I)=0.                                                           INIROG.42    
C                                                                          INIROG.43    
C     Override namelist switches for orographic masks if required.         INIROG.44    
C                                                                          INIROG.45    
      LAORF=(KOUNTA.GT.0).OR.(KOUNTF.GT.0)                                 INIROG.46    
      IF (.NOT.(LPC2.AND.LROG.AND.LINTP2.AND.LAORF)) THEN                  INIROG.47    
         IF (LMSK2) WRITE(6,6010)                                          INIROG.48    
         LMSK2=.FALSE.                                                     SUNMOD.43    
      ENDIF                                                                INIROG.50    
      IF (.NOT.(LPC3.AND.LROG.AND.LINTP3.AND.LAORF)) THEN                  INIROG.51    
         IF (LMSK3) WRITE(6,6020)                                          INIROG.52    
         LMSK3=.FALSE.                                                     SUNMOD.44    
      ENDIF                                                                INIROG.54    
C                                                                          INIROG.55    
      IF (.NOT.LROG) RETURN                                                INIROG.56    
C                                                                          INIROG.57    
      WRITE(6,6000)                                                        INIROG.58    
      IF (LMSK2) WRITE(6,6030)                                             INIROG.59    
      IF (LMSK3) WRITE(6,6040)                                             INIROG.60    
C                                                                          INIROG.61    
C     Read spectral orography.  Replace this simple read as necessary.     INIROG.62    
C                                                                          INIROG.63    
      READ(NCROGS) GS                                                      INIROG.64    
C*ULC CALL READD(GS,-1,3*NL+1,NHEM,NN,NCROGS)                              INIROG.65    
C*RAL CALL READD(GS,MM-1,1,NHEM,NN,NCROGS)                                 INIROG.66    
C                                                                          INIROG.67    
C     Transform to grid point space.                                       INIROG.68    
C                                                                          INIROG.69    
      IF (JGL.EQ.1) THEN                                                   INIROG.70    
         REWIND NCROGG                                                     INIROG.71    
         REWIND NCLEG                                                      INIROG.72    
         JL=1                                                              INIROG.73    
         DO 30 IH=1,JG                                                     INIROG.74    
         READ(NCLEG) ALP                                                   INIROG.75    
         CALL HEXP(GS,GSG(1,JL),1,2)                                       INIROG.76    
         CALL FFT991(GSG(1,JL),WORK,TRIG,IFAX,1,MGPP,MG,NHEM,1)            INIROG.77    
         WRITE(NCROGG) GSG                                                 INIROG.78    
   30    JL=JL+JINC                                                        INIROG.79    
         REWIND NCROGG                                                     INIROG.80    
         REWIND NCLEG                                                      INIROG.81    
      ELSE                                                                 INIROG.82    
         NBATCH=(JGG-1)/NCRAY                                              INIROG.83    
         NREST=JGG-NBATCH*NCRAY                                            INIROG.84    
         JL=1                                                              INIROG.85    
         DO 40 IH=1,JG                                                     INIROG.86    
         CALL HEXP(GS,GSG(1,JL),1,2)                                       INIROG.87    
   40    JL=JL+JINC                                                        INIROG.88    
         IF (NBATCH.EQ.0) GOTO 60                                          INIROG.89    
         DO 50 N=1,NBATCH                                                  INIROG.90    
   50    CALL FFT991(EGSG(1+(N-1)*NCRAY*MGPP),WORK,TRIG                    INIROG.91    
     :              ,IFAX,1,MGPP,MG,NCRAY,1)                               INIROG.92    
   60    CALL FFT991(EGSG(1+NBATCH*NCRAY*MGPP),WORK,TRIG                   INIROG.93    
     :              ,IFAX,1,MGPP,MG,NREST,1)                               INIROG.94    
      ENDIF                                                                INIROG.95    
C                                                                          INIROG.96    
C     Print/plot/dump orography depending on switches in /COMROG/.         INIROG.97    
C     If JGL=JG copy GSG into GPV and call OUTSUB with NC<=0,              INIROG.98    
C     since the input array is modified by OUTSUB.                         INIROG.99    
C                                                                          INIROG.100   
      LOUTP=KOUNTP.GT.0                                                    INIROG.101   
      LOUTF=KOUNTF.GT.0                                                    INIROG.102   
      LOUTA=KOUNTA.GT.0                                                    INIROG.103   
      LOUT=(LOUTP.AND.LROGGR).OR.((LOUTA.OR.LOUTF).AND.LROGPL)             INIROG.104   
      IF (LOUT) THEN                                                       INIROG.105   
         IF (JGL.EQ.JG) THEN                                               INIROG.106   
            DO 70 I=1,IGC*JG                                               INIROG.107   
   70       GPV(I)=EGSG(I)                                                 INIROG.108   
         ENDIF                                                             INIROG.109   
         NC=NCROGG                                                         INIROG.110   
         IF (JGL.EQ.JG) NC=-1                                              INIROG.111   
         CALL OUTSUB(GPV,NAME,NC,1,CG/GA,ROGFAC,ROGINC,LROGGR,LROGPL       INIROG.112   
     :              ,IZGTYP,0,0)                                           INIROG.113   
      ENDIF                                                                INIROG.114   
C                                                                          INIROG.115   
      RETURN                                                               INIROG.116   
      END                                                                  INIROG.117   
C     ****************************************************************     INIROG.118   
*DECK READD                                                                READD.1     
      SUBROUTINE READD(GS,MZONAL,NLL,NOHEM,NND,IUNIT)                      READD.2     
C                                                                          READD.3     
C     Read spectral orography data (MZONAL=>0) from channel IUNIT          READD.4     
C     or skip records (MZONAL<0).                                          READD.5     
C     Routine by Paul Valdes for data in 'READD' format.                   READD.6     
C                                                                          READD.7     
*CALL PARAM1                                                               READD.8     
      COMPLEX GS(*),DUM                                                    READD.9     
C                                                                          READD.10    
      IGA=NWJ2*NOHEM                                                       READD.11    
C                                                                          READD.12    
      IF (MZONAL.GT.(NND-1)) THEN                                          READD.13    
         WRITE(6,'('' ***ABORT IN READD: MZONAL ERROR'')')                 READD.14    
         CALL ABORT                                                        READD.15    
      ENDIF                                                                READD.16    
C                                                                          READD.17    
      IF (MZONAL.LT.0) THEN                                                READD.18    
         MSKIP=NLL*NND                                                     READD.19    
         IF (MSKIP.GT.0) THEN                                              READD.20    
            DO 10 I=1,MSKIP                                                READD.21    
   10       READ(IUNIT)                                                    READD.22    
         ENDIF                                                             READD.23    
         RETURN                                                            READD.24    
      ENDIF                                                                READD.25    
C                                                                          READD.26    
      MSKIP=NND-1-MZONAL                                                   READD.27    
      DO 50 L=1,NLL                                                        READD.28    
      II=(L-1)*IGA                                                         READD.29    
      DO 30 M=0,MZONAL                                                     READD.30    
      N=(NN+1-M)/2                                                         READD.31    
      N1=(NND+1-M)/2                                                       READD.32    
      N2=MIN(N,N1)                                                         READD.33    
      NDUM=N1-N2                                                           READD.34    
      IF (NOHEM.EQ.1) THEN                                                 READD.35    
         READ(IUNIT) (GS(I),I=II+1,II+N2)                                  READD.36    
      ELSE                                                                 READD.37    
         IF (NDUM.LE.0) THEN                                               READD.38    
         READ(IUNIT) (GS(I),I=II+1,II+N2)                                  READD.39    
     :              ,(GS(I),I=II+NWJ2+1,II+NWJ2+N2)                        READD.40    
         ELSE                                                              READD.41    
            READ(IUNIT) (GS(I),I=II+1,II+N2),(DUM,I=1,NDUM)                READD.42    
     :                 ,(GS(I),I=II+NWJ2+1,II+NWJ2+N2)                     READD.43    
         ENDIF                                                             READD.44    
      ENDIF                                                                READD.45    
      IF (M.EQ.0) THEN                                                     READD.46    
         DO 20 IHEM=1,NOHEM                                                READD.47    
         I1=(IHEM-1)*NWJ2                                                  READD.48    
         DO 20 I=1,N2                                                      READD.49    
   20    GS(II+I+I1)=CMPLX(REAL(GS(II+I+I1)),0.)                           READD.50    
      ENDIF                                                                READD.51    
   30 II=II+N                                                              READD.52    
      IF (MZONAL.LT.(NND-1).AND.MSKIP.GT.0) THEN                           READD.53    
         DO 40 I=1,MSKIP                                                   READD.54    
   40    READ(IUNIT)                                                       READD.55    
      ENDIF                                                                READD.56    
   50 CONTINUE                                                             READD.57    
C                                                                          READD.58    
      RETURN                                                               READD.59    
      END                                                                  READD.60    
C     ****************************************************************     READD.61    
*DECK HEXRES                                                               HEXRES.1     
      SUBROUTINE HEXRES                                                    HEXRES.2     
C                                                                          HEXRES.3     
C     Performs indirect Legendre transform for the zonally symmetric       HEXRES.4     
C     restoration temperature field.  Gives grid point values (same as     HEXRES.5     
C     Fourier coefficients for m=0) from spectral coefficients.            HEXRES.6     
C                                                                          HEXRES.7     
*CALL PARAM1                                                               HEXRES.8     
*CALL PARAM2                                                               HEXRES.9     
      PARAMETER(NVRG=NL*NHEM)                                              HEXRES.10    
C                                                                          HEXRES.11    
*CALL BLANK                                                                HEXRES.12    
*CALL COMIOC                                                               HEXRES.13    
*CALL LEGAU                                                                HEXRES.14    
*CALL POLYNO                                                               HEXRES.15    
*CALL SPECTR                                                               HEXRES.16    
*CALL TAV                                                                  HEXRES.17    
      REAL GV(NVRG)                                                        HEXRES.18    
C                                                                          HEXRES.19    
C     Loop over latitude for transform to grid point space.                HEXRES.20    
C                                                                          HEXRES.21    
      IF (JGL.EQ.1) REWIND NCLEG                                           HEXRES.22    
      JL=1                                                                 HEXRES.23    
      DO 100 IH=1,JG                                                       HEXRES.24    
      IF (JGL.EQ.1) READ(NCLEG) ALP                                        HEXRES.25    
C                                                                          HEXRES.26    
C     Preset grid point array to zero.                                     HEXRES.27    
C                                                                          HEXRES.28    
      DO 10 I=1,NVRG                                                       HEXRES.29    
   10 GV(I)=0.                                                             HEXRES.30    
C                                                                          HEXRES.31    
C     Calculate POLY array in vector loop before main transform.           HEXRES.32    
C                                                                          HEXRES.33    
      ISPAR=0                                                              HEXRES.34    
      DO 20 IHEM=1,NHEM                                                    HEXRES.35    
      INC=(IHEM-1)*(1-ISPAR)+(2-IHEM)*ISPAR                                HEXRES.36    
      IA=INC-1                                                             HEXRES.37    
      DO 20 IN=1,IDM                                                       HEXRES.38    
      IA=IA+2                                                              HEXRES.39    
   20 POLY(IN,IHEM)=ALP(IA,JL)                                             HEXRES.40    
C                                                                          HEXRES.41    
C     Perform inverse Legendre transform from spectral space               HEXRES.42    
C     for m=0 only, giving the half-sum and half-difference                HEXRES.43    
C     of the north/south grid point values.                                HEXRES.44    
C     Separate code for NHEM=1,2 to increase efficiency.                   HEXRES.45    
C                                                                          HEXRES.46    
      IF (NHEM.EQ.1) THEN                                                  HEXRES.47    
         IP=-IDM                                                           HEXRES.48    
         DO 40 IN=1,IDM                                                    HEXRES.49    
         IP=IP+1                                                           HEXRES.50    
         DO 40 IV=1,NVRG                                                   HEXRES.51    
   40    GV(IV)=GV(IV) + POLY(IN,1)*TRES(IP+IV*IDM)                        HEXRES.52    
      ELSE                                                                 HEXRES.53    
         IP=-IDM                                                           HEXRES.54    
         DO 50 IN=1,IDM                                                    HEXRES.55    
         IP=IP+1                                                           HEXRES.56    
         DO 50 IV=1,NVRG                                                   HEXRES.57    
         II=IV-((IV-1)/NHEM)*NHEM                                          HEXRES.58    
   50    GV(IV)=GV(IV) + POLY(IN,II)*TRES(IP+IV*IDM)                       HEXRES.59    
      ENDIF                                                                HEXRES.60    
C                                                                          HEXRES.61    
C     For a global run, sum and difference even and odd contributions      HEXRES.62    
C     to give the grid point values at the northern and southern           HEXRES.63    
C     latitude rows.  Code assumes even symmetry:                          HEXRES.64    
C          IGPAR=0 : even (IA) precedes odd (IB).                          HEXRES.65    
C                                                                          HEXRES.66    
      IF (NHEM.EQ.2) THEN                                                  HEXRES.67    
         IA=-1                                                             HEXRES.68    
CDIR$ IVDEP                                                                HEXRES.69    
         DO 60 L=1,NL                                                      HEXRES.70    
         IA=IA+2                                                           HEXRES.71    
         IB=IA+1                                                           HEXRES.72    
         TEMP=GV(IA)                                                       HEXRES.73    
         GV(IA)=TEMP+GV(IB)                                                HEXRES.74    
   60    GV(IB)=TEMP-GV(IB)                                                HEXRES.75    
      ENDIF                                                                HEXRES.76    
C                                                                          HEXRES.77    
C     Set up zonal array of restoration temperatures, including TMEAN.     HEXRES.78    
C                                                                          HEXRES.79    
      DO 70 IHEM=1,NHEM                                                    HEXRES.80    
      I=IHEM                                                               HEXRES.81    
      IK=(3-2*IHEM)*IH+JGGP*(IHEM-1)                                       HEXRES.82    
      DO 70 L=1,NL                                                         HEXRES.83    
      TBRES(IK,L)=GV(I)+TMEAN(L)                                           HEXRES.84    
   70 I=I+NHEM                                                             HEXRES.85    
C                                                                          HEXRES.86    
  100 JL=JL+JINC                                                           HEXRES.87    
C                                                                          HEXRES.88    
      RETURN                                                               HEXRES.89    
      END                                                                  HEXRES.90    
C     ****************************************************************     HEXRES.91    
*DECK RCHECK                                                               RCHECK.1     
      SUBROUTINE RCHECK(NCHAN,RNTAPE,KOUNT,TSPD)                           RCHECK.2     
C                                                                          RCHECK.3     
C     Check label on next history record.  Skip forward to required        RCHECK.4     
C     analysis time if necessary, or abort if already passed.              RCHECK.5     
C                                                                          RCHECK.6     
 6900 FORMAT(/' ***ABORT IN RCHECK: RNTAPE CONFLICT ON READ')              RCHECK.7     
 6910 FORMAT(/' ***ABORT IN RCHECK: RKOUNT MISSED ON READ')                RCHECK.8     
 6920 FORMAT(/' ***ABORT IN RCHECK: EOF ENCOUNTERED')                      RCHECK.9     
 6990 FORMAT(/' PROGRAM VALUES:      KOUNT  RNTAPE DAY  =',I12,2F12.3      RCHECK.10    
     :       /' HISTORY FILE VALUES: RKOUNT RMTAPE RDAY =',3F12.3)         RCHECK.11    
C                                                                          RCHECK.12    
      DAY=FLOAT(KOUNT)/TSPD                                                RCHECK.13    
C                                                                          RCHECK.14    
   10 READ(NCHAN,END=90) RKOUNT,RMTAPE,RDAY                                RCHECK.15    
      IF (ABS(RMTAPE-RNTAPE).GT.1.0E-10) THEN                              RCHECK.16    
         WRITE(6,6900)                                                     RCHECK.17    
         WRITE(6,6990) KOUNT,RNTAPE,DAY,RKOUNT,RMTAPE,RDAY                 RCHECK.18    
         CALL ABORT                                                        RCHECK.19    
      ENDIF                                                                RCHECK.20    
      MOUNT=NINT(RDAY*TSPD)                                                RCHECK.21    
      IF (MOUNT.LT.KOUNT) GOTO 10                                          RCHECK.22    
C                                                                          RCHECK.23    
      IF (MOUNT.GT.KOUNT) THEN                                             RCHECK.24    
         WRITE(6,6910)                                                     RCHECK.25    
         WRITE(6,6990) KOUNT,RNTAPE,DAY,RKOUNT,RMTAPE,RDAY                 RCHECK.26    
         CALL ABORT                                                        RCHECK.27    
      ENDIF                                                                RCHECK.28    
C                                                                          RCHECK.29    
      BACKSPACE NCHAN                                                      RCHECK.30    
      RETURN                                                               RCHECK.31    
C                                                                          RCHECK.32    
   90 WRITE(6,6920)                                                        RCHECK.33    
      WRITE(6,6990) KOUNT,RNTAPE,DAY,RKOUNT,RMTAPE,RDAY                    RCHECK.34    
      CALL ABORT                                                           RCHECK.35    
C                                                                          RCHECK.36    
      END                                                                  RCHECK.37    
C     ****************************************************************     RCHECK.38    
*DECK PHYSOP                                                               PHYSOP.1     
      SUBROUTINE PHYSOP                                                    PHYSOP.2     
C                                                                          PHYSOP.3     
C     Process 2-D surface fields of parameterisation diagnostics           PHYSOP.4     
C     at current analysis time.  Contained on JG records of history        PHYSOP.5     
C     file.  Skip and return if diagnostics not required.                  PHYSOP.6     
C                                                                          PHYSOP.7     
C     (NPH-1) instantaneous and daily-averaged fields are read, with       PHYSOP.8     
C     convective and large-scale rainfall rates last.  These are added     PHYSOP.9     
C     for the total rainfall in the (NPH)th field.                         PHYSOP.10    
C        NT=1 : instantaneous fields.                                      PHYSOP.11    
C        NT=2 : fields averaged over preceding KOUNTP steps in model.      PHYSOP.12    
C                                                                          PHYSOP.13    
C     NB.  Common SPECTR is used as workspace for GPV array.               PHYSOP.14    
C     NB.  Current code equivalences both the unused vector arrays GX      PHYSOP.15    
C     and GY to GVE( ,3) in common DUM, since GVE is only 3 fields long.   PHYSOP.16    
C                                                                          PHYSOP.17    
*CALL PARAM1                                                               PHYSOP.18    
*CALL PARAM2                                                               PHYSOP.19    
      PARAMETER(NCNT=50,NCR=NPH-2,NLR=NPH-1)                               PHYSOP.20    
C                                                                          PHYSOP.21    
*CALL BATS                                                                 PHYSOP.22    
*CALL BLANK                                                                PHYSOP.23    
*CALL COMIOC                                                               PHYSOP.24    
*CALL COMMSK                                                               PHYSOP.25    
*CALL DUM                                                                  PHYSOP.26    
*CALL LEGAU                                                                PHYSOP.28    
*CALL OUTCON                                                               PHYSOP.29    
*CALL SPECTR                                                               PHYSOP.30    
      REAL GPV(MGPP,NHEM,JG,NPH,2)                                         PHYSOP.31    
      EQUIVALENCE (GPV(1,1,1,1,1),Z(1))                                    PHYSOP.32    
      REAL GV(MGP,JGGP,2),GX(MGP,JGGP),GY(MGP,JGGP)                        PHYSOP.33    
      EQUIVALENCE (GV,GVE(1,1)),(GX,GVE(1,3)),(GY,GVE(1,3))                PHYSOP.34    
      REAL DFAC(NPH),PHMN(NPH,2)                                           PHYSOP.35    
      REAL CL(NCNT,2),GNORM(2),GINC(2),GMIN(2),GMAX(2)                     PHYSOP.36    
      INTEGER ICNT(2),ICSTYL(2)                                            PHYSOP.37    
      LOGICAL LPRINT,LPLOT,LDUMP,LVEC                                      PHYSOP.38    
      CHARACTER NAMES(NPH)*50,NAMC*50,TIMANN(2)*6                          PHYSOP.39    
      SAVE NAMES,TIMANN                                                    PHYSOP.40    
C                                                                          PHYSOP.41    
      DATA (NAMES(N),N=1,NPH)/                                             PHYSOP.42    
     1 'SURFACE STRESS                           N/M2     '                PHYSOP.43    
     2,'SURFACE HEAT FLUX                        W/M2     '                PHYSOP.44    
     3,'SURFACE LATENT FLUX                      W/M2     '                PHYSOP.45    
     4,'CONVECTIVE RAINFALL                      MM/DAY   '                PHYSOP.46    
     5,'LARGE SCALE RAINFALL                     MM/DAY   '                PHYSOP.47    
     6,'TOTAL RAINFALL                           MM/DAY   '                PHYSOP.48    
     :/                                                                    PHYSOP.49    
      DATA TIMANN/'(INST)','(AVER)'/                                       PHYSOP.50    
C                                                                          PHYSOP.51    
 6000 FORMAT(' PROCESSING SURFACE FIELDS    AT DAY',F10.2,' KOUNT=',I10)   PHYSOP.52    
 6010 FORMAT(/' DAY',F10.2,'  NUMBER OF TIMESTEPS COMPLETED =',I10)        PHYSOP.53    
 6900 FORMAT(' ***ABORT IN PHYSOP AT DAY',F10.2                            PHYSOP.54    
     :      ,' : LATITUDE COUNTER IN DATA =',I5,'  NOT',I5)                PHYSOP.55    
C                                                                          PHYSOP.56    
C     Read JG records of 2D surface fields if output required at this      PHYSOP.57    
C     analysis time, or skip if not.                                       PHYSOP.58    
C     Daily-averaged fields precede instantaneous on history file.         PHYSOP.59    
C                                                                          PHYSOP.60    
      CALL RCHECK(NCHIST,RNTAPE,KOUNT,TSPD)                                PHYSOP.61    
      IF ((LPC7.AND.LOUT).OR.LPC9) THEN                                    PHYSOP.62    
         DO 10 J=1,JG                                                      PHYSOP.63    
         READ(NCHIST) RKOUNT,RMTAPE,DAY,RNR                                PHYSOP.64    
     :           ,((((GPV(I,IHEM,J,K,NT)                                   PHYSOP.65    
     :              ,I=1,MGPP),IHEM=1,NHEM),K=1,NLR),NT=2,1,-1)            PHYSOP.66    
     :           ,RMTAPE                                                   PHYSOP.67    
         IF (NINT(RNR).NE.J) THEN                                          PHYSOP.68    
            WRITE(6,6900) DAY,NINT(RNR),J                                  PHYSOP.69    
            CALL ABORT                                                     PHYSOP.70    
         ENDIF                                                             PHYSOP.71    
   10    CONTINUE                                                          PHYSOP.72    
      ELSE                                                                 PHYSOP.73    
         DO 20 J=1,JG                                                      PHYSOP.74    
   20    READ(NCHIST)                                                      PHYSOP.75    
         RETURN                                                            PHYSOP.76    
      ENDIF                                                                PHYSOP.77    
C                                                                          PHYSOP.78    
C     Write header and define dimensionalising factors and constants.      PHYSOP.79    
C                                                                          PHYSOP.80    
      IF (NPC7.NE.6) THEN                                                  PHYSOP.81    
         IF (LOUTP) WRITE(NPC7,'(///)')                                    PHYSOP.82    
         WRITE(NPC7,6000) DAY,KOUNT                                        PHYSOP.83    
      ENDIF                                                                PHYSOP.84    
      WRITE(6,6000) DAY,KOUNT                                              PHYSOP.85    
C                                                                          PHYSOP.86    
      DFAC(1)=P0                                                           PHYSOP.87    
      DFAC(2)=CV*P0                                                        PHYSOP.88    
      DFAC(3)=CV*P0                                                        PHYSOP.89    
      DFAC(4)=TSPD                                                         PHYSOP.90    
      DFAC(5)=TSPD                                                         PHYSOP.91    
      DFAC(6)=TSPD                                                         PHYSOP.92    
C                                                                          PHYSOP.93    
      IPTYP=IZGTYP                                                         PHYSOP.94    
      LVEC=.FALSE.                                                         SUNMOD.45    
      IMSK=0                                                               PHYSOP.96    
C                                                                          PHYSOP.97    
C     Process data in main loops over fields.                              PHYSOP.98    
C     NT=1,2 for instantaneous then time-averaged fields.                  PHYSOP.99    
C     IOUT=1,NPH for individual fields, with special treatment for         PHYSOP.100   
C     rainfall fields.                                                     PHYSOP.101   
C     Also calculate global means in PHMN for routine PHYSAV.              PHYSOP.102   
C                                                                          PHYSOP.103   
      DO 200 NT=1,2                                                        PHYSOP.104   
      IF (LPC7.AND.LOUTP) WRITE(NPC7,6010) DAY,KOUNT                       PHYSOP.105   
C                                                                          PHYSOP.106   
      DO 50 IHEM=1,NHEM                                                    PHYSOP.107   
      DO 50 J=1,JG                                                         PHYSOP.108   
      DO 30 IOUT=1,NLR                                                     PHYSOP.109   
      DO 30 I=1,MG                                                         PHYSOP.110   
   30 GPV(I,IHEM,J,IOUT,NT)=GPV(I,IHEM,J,IOUT,NT)*DFAC(IOUT)               PHYSOP.111   
      DO 40 I=1,MGPP                                                       PHYSOP.112   
   40 GPV(I,IHEM,J,NPH,NT)=GPV(I,IHEM,J,NCR,NT)+GPV(I,IHEM,J,NLR,NT)       PHYSOP.113   
   50 CONTINUE                                                             PHYSOP.114   
C                                                                          PHYSOP.115   
      DO 100 IOUT=1,NPH                                                    PHYSOP.116   
      LPRINT=LOUTP.AND.LPHGR(IOUT)                                         PHYSOP.117   
      LPLOT =LOUTF.AND.LPHPL(IOUT)                                         PHYSOP.118   
      LDUMP =LOUTA.AND.LPHPL(IOUT)                                         PHYSOP.119   
      IF (.NOT.(LPRINT.OR.LPLOT.OR.LDUMP.OR.LPC9)) GOTO 100                PHYSOP.120   
      N=1                                                                  PHYSOP.121   
      IFRAME=1                                                             PHYSOP.122   
      IF (IOUT.EQ.NCR.AND.(LPLOT.OR.LDUMP).AND.LPHPL(NLR)) THEN            PHYSOP.123   
         ICSTYL(N)=-1                                                      PHYSOP.124   
      ELSE IF (IOUT.EQ.NLR.AND.(LPLOT.OR.LDUMP).AND.LPHPL(NCR)) THEN       PHYSOP.125   
         N=2                                                               PHYSOP.126   
         IFRAME=0                                                          PHYSOP.127   
         ICSTYL(N)=1                                                       PHYSOP.128   
      ELSE                                                                 PHYSOP.129   
         ICSTYL(N)=0                                                       PHYSOP.130   
      ENDIF                                                                PHYSOP.131   
      NAMES(IOUT)(25:30)=TIMANN(NT)                                        PHYSOP.132   
C                                                                          PHYSOP.133   
      DO 70 IHEM=1,NHEM                                                    PHYSOP.134   
      DO 70 J=1,JG                                                         PHYSOP.135   
      JJ=(2-IHEM)*J + (IHEM-1)*(JGGP+1-J)                                  PHYSOP.136   
      JZ=JJ-(IHEM-1)                                                       PHYSOP.137   
      GVZ(JZ,1)=SSUM(MG,GPV(1,IHEM,J,IOUT,NT),1)*RMG                       PHYSOP.138   
      DO 60 I=1,MG                                                         PHYSOP.139   
   60 GV(I,JJ,N)=GPV(I,IHEM,J,IOUT,NT)                                     PHYSOP.140   
   70 CONTINUE                                                             PHYSOP.141   
      IF (LPC9) PHMN(IOUT,NT)=SDOT(JGG,GVZ,1,GWT,1)                        PHYSOP.142   
      IF (.NOT.(LPRINT.OR.LPLOT.OR.LDUMP)) GOTO 100                        PHYSOP.143   
C                                                                          PHYSOP.144   
      CALL GVPREP(GV(1,1,N),PHFAC(IOUT),PHINC(IOUT),CL(1,N),NCNT           PHYSOP.145   
     :           ,GNORM(N),GINC(N),ICNT(N),GMIN(N),GMAX(N),IFAIL)          PHYSOP.146   
      IF (IFAIL.NE.0) CALL GFAIL(IFAIL,LPRINT,LPLOT,LDUMP                  PHYSOP.147   
     :                          ,NAMES(IOUT)(1:30),ICNT(N))                PHYSOP.148   
C                                                                          PHYSOP.149   
      IF (LPRINT) THEN                                                     PHYSOP.150   
        CALL GPRINT(GV(1,1,N),NAMES(IOUT),GMIN(N),GMAX(N),GNORM(N),NPC7)   PHYSOP.151   
        WRITE(NAMC,'(A,A,10X)') NAMES(IOUT)(1:30),NAMES(IOUT)(41:50)       PHYSOP.152   
        CALL XSECT(GVZ,1,NAMC,NPC7,PHFAC(IOUT),0.,LPRINT                   PHYSOP.153   
     :            ,.FALSE.,.FALSE.,.TRUE.,0,0,0)                           SUNMOD.46    
      ENDIF                                                                PHYSOP.155   
C                                                                          PHYSOP.156   
      IF (LDUMP)                                                           PHYSOP.157   
     :   CALL WTFUTF(GV(1,1,N),MGP,JGGP,IPTYP,ICSTYL(N),0,5,IFRAME,IMSK    PHYSOP.158   
     :           ,GMIN(N),GMAX(N),GINC(N),DAY,NAMES(IOUT),50,NPCA,IFAIL)   PHYSOP.159   
C                                                                          PHYSOP.160   
      IF (.NOT.LPLOT) GOTO 100                                             PHYSOP.161   
      IF (IOUT.EQ.NCR.AND.LPLOT.AND.LPHPL(NLR)) GOTO 100                   PHYSOP.162   
      IO=IOUT                                                              PHYSOP.163   
      IF (IOUT.EQ.NLR) IO=NCR                                              PHYSOP.164   
C                                                                          PHYSOP.170   
  100 CONTINUE                                                             PHYSOP.171   
  200 CONTINUE                                                             PHYSOP.172   
C                                                                          PHYSOP.173   
C     Write global means to channel NCGDG for output by routine PHYSAV     PHYSOP.174   
C     at end of run.                                                       PHYSOP.175   
C                                                                          PHYSOP.176   
      IF (.NOT.LPC9) RETURN                                                PHYSOP.177   
      WRITE(NCGDG) KOUNT,DAY                                               PHYSOP.178   
      WRITE(NCGDG) PHMN                                                    PHYSOP.179   
      IF (KOUNT.EQ.KEND) THEN                                              PHYSOP.180   
         JOUNT=-999                                                        PHYSOP.181   
         TDAY=-999.                                                        PHYSOP.182   
         WRITE(NCGDG) JOUNT,TDAY                                           PHYSOP.183   
      ENDIF                                                                PHYSOP.184   
C                                                                          PHYSOP.185   
      RETURN                                                               PHYSOP.186   
      END                                                                  PHYSOP.187   
C     ****************************************************************     PHYSOP.188   
*DECK PHYSEC                                                               PHYSEC.1     
      SUBROUTINE PHYSEC                                                    PHYSEC.2     
C                                                                          PHYSEC.3     
C     Process zonally averaged parameterisation tendencies at current      PHYSEC.4     
C     analysis time and increment time averages.  When called with         PHYSEC.5     
C     KOUNT < 0 at end of run, just output the time averaged fields.       PHYSEC.6     
C     N=1 for instantaneous values.                                        PHYSEC.7     
C     N=2 for values averaged over preceding KOUNTP model timesteps.       PHYSEC.8     
C     N=3 for time averages formed by accumulating N=2 values.             PHYSEC.9     
C                                                                          PHYSEC.10    
*CALL PARAM1                                                               PHYSEC.11    
*CALL PARAM2                                                               PHYSEC.12    
*CALL BATS                                                                 PHYSEC.13    
*CALL BLANK                                                                PHYSEC.14    
*CALL COMIOC                                                               PHYSEC.15    
*CALL LEGAU                                                                PHYSEC.17    
*CALL OUTCON                                                               PHYSEC.18    
*CALL PHYS                                                                 PHYSEC.19    
*CALL ZONAVP                                                               PHYSEC.20    
      REAL PPZ(IGG,3,NXP),PPZEQ(3*IPPZ),DFAC(NXP)                          PHYSEC.21    
      EQUIVALENCE (PPZ(1,1,1),PPZEQ(1),UTVDZ(1,1))                         PHYSEC.22    
      LOGICAL LSW(NXP),LPH,LSTART,LPRINT,LPLOT,LDUMP                       PHYSEC.23    
      CHARACTER NAME(NXP)*45,TIMANN(3)*7                                   PHYSEC.24    
      SAVE NAME,TIMANN,DFAC,LSTART,LSW,LPH                                 PHYSEC.25    
C                                                                          PHYSEC.26    
      DATA (NAME(J),J=1,15)/                                               PHYSEC.27    
     1 'U-TEND VD                      M/S/DAY       '                     PHYSEC.28    
     2,'V-TEND VD                      M/S/DAY       '                     PHYSEC.29    
     3,'T-TEND VD                      K/DAY         '                     PHYSEC.30    
     4,'Q-TEND VD                      G/KG/DAY      '                     PHYSEC.31    
     5,'T-TEND CR                      K/DAY         '                     PHYSEC.32    
     6,'Q-TEND CR                      G/KG/DAY      '                     PHYSEC.33    
     7,'T-TEND LR                      K/DAY         '                     PHYSEC.34    
     8,'Q-TEND LR                      G/KG/DAY      '                     PHYSEC.35    
     9,'T-TEND RD                      K/DAY         '                     PHYSEC.36    
     :,'U-TEND BL                      M/S/DAY       '                     PHYSEC.37    
     1,'V-TEND BL                      M/S/DAY       '                     PHYSEC.38    
     2,'T-TEND BL                      K/DAY         '                     PHYSEC.39    
     3,'Q-TEND BL                      G/KG/DAY      '                     PHYSEC.40    
     4,'U-TEND TOTAL                   M/S/DAY       '                     PHYSEC.41    
     5,'V-TEND TOTAL                   M/S/DAY       '                     PHYSEC.42    
     :/                                                                    PHYSEC.43    
      DATA (NAME(J),J=16,NXP)/                                             PHYSEC.44    
     6 'T-TEND TOTAL                   K/DAY         '                     PHYSEC.45    
     7,'Q-TEND TOTAL                   G/KG/DAY      '                     PHYSEC.46    
     8,'CONVECTION COUNTER                           '                     PHYSEC.47    
     9,'LSR COUNTER                                  '                     PHYSEC.48    
     :/                                                                    PHYSEC.49    
      DATA TIMANN/' (INST)',' (AVER)',' (TAV) '/                           PHYSEC.50    
      DATA LSTART/.TRUE./                                                  SUNMOD.47    
C                                                                          PHYSEC.52    
 6000 FORMAT(' PROCESSING PHYSICS Z-SECTS   AT DAY',F10.2,' KOUNT=',I10)   PHYSEC.53    
 6010 FORMAT(' PROCESSING PHYSICS Z-SECTS   FOR TIME AVERAGES')            PHYSEC.54    
 6900 FORMAT(' ***ABORT IN PHYSEC AT DAY',F10.2,                           PHYSEC.55    
     :       ' : RECORD COUNTER =',I5,'   NOT JGP')                        PHYSEC.56    
C                                                                          PHYSEC.57    
C     On first call set up and save switches and factors and preset PPZ.   PHYSEC.58    
C                                                                          PHYSEC.59    
      IF (LSTART) THEN                                                     PHYSEC.60    
         LPH=LVD.OR.LCR.OR.LLR.OR.LRD.OR.LBL                               PHYSEC.61    
         CVT=PI2*CV                                                        PHYSEC.62    
         CQT=PI2*CQ                                                        PHYSEC.63    
         DFAC(1)=CVT                                                       PHYSEC.64    
         DFAC(2)=CVT                                                       PHYSEC.65    
         DFAC(3)=CTT                                                       PHYSEC.66    
         DFAC(4)=CQT                                                       PHYSEC.67    
         DFAC(5)=CTT                                                       PHYSEC.68    
         DFAC(6)=CQT                                                       PHYSEC.69    
         DFAC(7)=CTT                                                       PHYSEC.70    
         DFAC(8)=CQT                                                       PHYSEC.71    
         DFAC(9)=CTT                                                       PHYSEC.72    
         DFAC(10)=CVT                                                      PHYSEC.73    
         DFAC(11)=CVT                                                      PHYSEC.74    
         DFAC(12)=CTT                                                      PHYSEC.75    
         DFAC(13)=CQT                                                      PHYSEC.76    
         DFAC(14)=CVT                                                      PHYSEC.77    
         DFAC(15)=CVT                                                      PHYSEC.78    
         DFAC(16)=CTT                                                      PHYSEC.79    
         DFAC(17)=CQT                                                      PHYSEC.80    
         DFAC(18)=1                                                        PHYSEC.81    
         DFAC(19)=1                                                        PHYSEC.82    
         DO 10 IOUT=1,4                                                    PHYSEC.83    
   10    LSW(IOUT)=LVD                                                     PHYSEC.84    
         LSW(  5 )=LCR                                                     PHYSEC.85    
         LSW(  6 )=LCR                                                     PHYSEC.86    
         LSW(  7 )=LLR                                                     PHYSEC.87    
         LSW(  8 )=LLR                                                     PHYSEC.88    
         LSW(  9 )=LRD                                                     PHYSEC.89    
         DO 20 IOUT=10,13                                                  PHYSEC.90    
   20    LSW(IOUT)=LBL                                                     PHYSEC.91    
         LSW( 14 )=LVD.AND.LBL                                             PHYSEC.92    
         LSW( 15 )=LVD.AND.LBL                                             PHYSEC.93    
         LSW( 16 )=.TRUE.                                                  SUNMOD.48    
         LSW( 17 )=.TRUE.                                                  SUNMOD.49    
         LSW( 18 )=LCR                                                     PHYSEC.96    
         LSW( 19 )=LLR                                                     PHYSEC.97    
         DO 30 I=1,3*IPPZ                                                  PHYSEC.98    
   30    PPZEQ(I)=0.                                                       PHYSEC.99    
         LSTART=.FALSE.                                                    SUNMOD.50    
      ENDIF                                                                PHYSEC.101   
      IZDIM=1                                                              PHYSEC.102   
C                                                                          PHYSEC.103   
C     Read data at current analysis time if KOUNT >= 0.                    PHYSEC.104   
C     Check switches and return if no output required.                     PHYSEC.105   
C                                                                          PHYSEC.106   
      IF (KOUNT.GE.0) THEN                                                 PHYSEC.107   
         CALL RCHECK(NCHIST,RNTAPE,KOUNT,TSPD)                             PHYSEC.108   
         IF (LPC8.AND.LPH.AND.(LTAV.OR.LOUT)) THEN                         PHYSEC.109   
            INL=NLM*JGG+1                                                  PHYSEC.110   
            READ(NCHIST) RKOUNT,RMTAPE,DAY,RNR                             PHYSEC.111   
     :       ,((UTVDZ(I,N),I=1,IGG),(VTVDZ(I,N),I=1,IGG)                   PHYSEC.112   
     :        ,(TTVDZ(I,N),I=1,IGG),(QTVDZ(I,N),I=1,IGG)                   PHYSEC.113   
     :        ,(TTCRZ(I,N),I=1,IGG),(QTCRZ(I,N),I=1,IGG)                   PHYSEC.114   
     :        ,(TTLRZ(I,N),I=1,IGG),(QTLRZ(I,N),I=1,IGG)                   PHYSEC.115   
     :        ,(TTRDZ(I,N),I=1,IGG)                                        PHYSEC.116   
     :        ,(CTCRZ(I,N),I=1,IGG),(CTLRZ(I,N),I=1,IGG)                   PHYSEC.117   
     :        ,(UTBLZ(I,N),I=INL,IGG),(VTBLZ(I,N),I=INL,IGG)               PHYSEC.118   
     :        ,(TTBLZ(I,N),I=INL,IGG),(QTBLZ(I,N),I=INL,IGG)               PHYSEC.119   
     :        ,N=2,1,-1),RMTAPE                                            PHYSEC.120   
            IF (NINT(RNR).NE.JGP) THEN                                     PHYSEC.121   
               WRITE(6,6900) DAY,NINT(RNR)                                 PHYSEC.122   
               CALL ABORT                                                  PHYSEC.123   
            ENDIF                                                          PHYSEC.124   
         ELSE                                                              PHYSEC.125   
            READ(NCHIST)                                                   PHYSEC.126   
            RETURN                                                         PHYSEC.127   
         ENDIF                                                             PHYSEC.128   
      ELSE                                                                 PHYSEC.129   
         IF (.NOT.(LPC8.AND.LPH.AND.LTAV.AND.LOUT)) RETURN                 PHYSEC.130   
      ENDIF                                                                PHYSEC.131   
C                                                                          PHYSEC.132   
C     Write header.  Set up loop limits for current time or averages.      PHYSEC.133   
C                                                                          PHYSEC.134   
      IF (LOUTP.AND.NPC8.NE.6) WRITE(NPC8,'(///)')                         PHYSEC.135   
      IF (KOUNT.GE.0) THEN                                                 PHYSEC.136   
         NMIN=1                                                            PHYSEC.137   
         NMAX=2                                                            PHYSEC.138   
         IF (NPC8.NE.6) WRITE(NPC8,6000) DAY,KOUNT                         PHYSEC.139   
         WRITE(6,6000) DAY,KOUNT                                           PHYSEC.140   
      ELSE                                                                 PHYSEC.141   
         NMIN=3                                                            PHYSEC.142   
         NMAX=3                                                            PHYSEC.143   
         IF (NPC2.NE.6) WRITE(NPC8,6010)                                   PHYSEC.144   
         WRITE(6,6010)                                                     PHYSEC.145   
      ENDIF                                                                PHYSEC.146   
C                                                                          PHYSEC.147   
C     Process data.                                                        PHYSEC.148   
C                                                                          PHYSEC.149   
      DO 200 N=NMIN,NMAX                                                   PHYSEC.150   
      IF (KOUNT.GE.0) THEN                                                 PHYSEC.151   
         DO 100 L=1,NL                                                     PHYSEC.152   
         IOF=(L-1)*JGG                                                     PHYSEC.153   
         DO 100 J=1,JGG                                                    PHYSEC.154   
         I=IOF+J                                                           PHYSEC.155   
         UTVDZ(I,N)=UTVDZ(I,N)/CS(J)                                       PHYSEC.156   
         VTVDZ(I,N)=VTVDZ(I,N)/CS(J)                                       PHYSEC.157   
         UTBLZ(I,N)=UTBLZ(I,N)/CS(J)                                       PHYSEC.158   
  100    VTBLZ(I,N)=VTBLZ(I,N)/CS(J)                                       PHYSEC.159   
         DO 110 I=1,IGG                                                    PHYSEC.160   
         UTOTZ(I,N)=UTBLZ(I,N)+UTVDZ(I,N)                                  PHYSEC.161   
         VTOTZ(I,N)=VTBLZ(I,N)+VTVDZ(I,N)                                  PHYSEC.162   
         TTOTZ(I,N)=TTBLZ(I,N)+TTVDZ(I,N)+TTCRZ(I,N)+TTLRZ(I,N)            PHYSEC.163   
     :             +TTRDZ(I,N)                                             PHYSEC.164   
  110    QTOTZ(I,N)=QTBLZ(I,N)+QTVDZ(I,N)+QTCRZ(I,N)+QTLRZ(I,N)            PHYSEC.165   
         IF (LTAV.AND.KOUNT.GT.KSTART.AND.N.EQ.2) THEN                     PHYSEC.166   
            DO 120 IOUT=1,NXP                                              PHYSEC.167   
            DO 120 I=1,IGG                                                 PHYSEC.168   
  120       PPZ(I,3,IOUT)=PPZ(I,3,IOUT)+FTAV*PPZ(I,2,IOUT)                 PHYSEC.169   
         ENDIF                                                             PHYSEC.170   
      ENDIF                                                                PHYSEC.171   
      DO 150 IOUT=1,NXP                                                    PHYSEC.172   
      LPRINT=LOUTP.AND.LSW(IOUT).AND.LXPGR(IOUT)                           PHYSEC.173   
      LPLOT =LOUTF.AND.LSW(IOUT).AND.LXPPL(IOUT).AND.(N.NE.2)              PHYSEC.174   
      LDUMP =LOUTA.AND.LSW(IOUT).AND.LXPPL(IOUT).AND.(N.NE.2)              PHYSEC.175   
      IF (.NOT.(LPRINT.OR.LPLOT.OR.LDUMP)) GOTO 150                        PHYSEC.176   
      DO 130 I=1,IGG                                                       PHYSEC.177   
  130 PPZ(I,N,IOUT)=PPZ(I,N,IOUT)*DFAC(IOUT)                               PHYSEC.178   
      NAME(IOUT)(21:27)=TIMANN(N)                                          PHYSEC.179   
      ICSTYL=0                                                             PHYSEC.180   
      CALL XSECT(PPZ(1,N,IOUT),NL,NAME(IOUT),NPC8,XPFAC(IOUT)              PHYSEC.181   
     :          ,XPINC(IOUT),LPRINT,LPLOT,LDUMP,.TRUE.,ICSTYL,IZDIM,0)     SUNMOD.51    
      DO 140 I=1,IGG                                                       PHYSEC.183   
  140 PPZ(I,N,IOUT)=PPZ(I,N,IOUT)/DFAC(IOUT)                               PHYSEC.184   
  150 CONTINUE                                                             PHYSEC.185   
  200 CONTINUE                                                             PHYSEC.186   
C                                                                          PHYSEC.187   
      RETURN                                                               PHYSEC.188   
      END                                                                  PHYSEC.189   
C     ****************************************************************     PHYSEC.190   
*DECK PHYSAV                                                               PHYSAV.1     
      SUBROUTINE PHYSAV                                                    PHYSAV.2     
C                                                                          PHYSAV.3     
C     Process time series and time averages of globally averaged           PHYSAV.4     
C     parameterisation diagnostics.  These have been accumulated           PHYSAV.5     
C     on channel NCGDG by routine PHYSOP at each analysis time.            PHYSAV.6     
C     PHMN(K,1) contains instantaneous values.                             PHYSAV.7     
C     PHMN(K,2) contains values averaged over previous KOUNTP steps.       PHYSAV.8     
C     PHMN(K,3) contains time averages over entire run using the           PHYSAV.9     
C               PHMN(K,2) values, so omitting KSTART.                      PHYSAV.10    
C     NB.  Time averages are for period KSTART to KEND, irrespective       PHYSAV.11    
C     of whether parameterisations active from KBEGP > KSTART.             PHYSAV.12    
C     NB.  PHYSAV must only be called after final call to GDIAG, since     PHYSAV.13    
C     the time series array ADIAG is equivalenced to an array in           PHYSAV.14    
C     common SERIES used by GDIAG.                                         PHYSAV.15    
C                                                                          PHYSAV.16    
*CALL PARAM1                                                               PHYSAV.17    
*CALL PARAM2                                                               PHYSAV.18    
*CALL BATS                                                                 PHYSAV.19    
*CALL BLANK                                                                PHYSAV.20    
*CALL COMIOC                                                               PHYSAV.21    
*CALL OUTCON                                                               PHYSAV.22    
*CALL PHYS                                                                 PHYSAV.23    
*CALL SERIES                                                               PHYSAV.24    
      REAL PHMN(NPH,3),ADIAG(NPMAX9,8),ADMX(3),ADMN(3)                     PHYSAV.25    
      INTEGER NI(3),IYD(3)                                                 PHYSAV.26    
      CHARACTER IXLAB*22,IYLAB(3)*30,IDAN(8)*3,LTEMP*8,TIMANN(3)*7         PHYSAV.27    
      EQUIVALENCE (ADIAG(1,1),ACONV(1,1))                                  PHYSAV.28    
C                                                                          PHYSAV.29    
      DATA NI/1,3,4/,IYD/10,20,10/,ADMX/1.,200.,10./,ADMN/3*0./            PHYSAV.30    
      DATA IXLAB/'    TIME IN DAYS*.'/                                     PHYSAV.31    
      DATA IYLAB/'         SURFACE STRESS N/M2*.'                          PHYSAV.32    
     :,          '         SURFACE FLUXES W/M2*.'                          PHYSAV.33    
     :,          '         PRECIP/EVAP MM/DAY*.'                           PHYSAV.34    
     :/                                                                    PHYSAV.35    
      DATA LTEMP/'      *.'/                                               PHYSAV.36    
      DATA IDAN /'TAU','  H','  L','  R',' CR',' LR','  R','  E'/          PHYSAV.37    
      DATA TIMANN/'(INST) ','(AVER) ',' (TAV) '/                           PHYSAV.38    
C                                                                          PHYSAV.39    
 6000 FORMAT(' GLOBAL SURFACE DIAGNOSTICS AT DAY ',F6.2)                   PHYSAV.40    
 6010 FORMAT(' TIME AVERAGE GLOBAL SURFACE DIAGNOSTICS')                   PHYSAV.41    
 6020 FORMAT(1P,5X,A,'  HFLUX=',E12.5,'  LFLUX=',E12.5                     PHYSAV.42    
     :              ,' PRECIP=',E12.5,' W/M2   STRESS=',E12.5,' N/M2')     PHYSAV.43    
 6030 FORMAT(1P,5X,A,'  CRAIN=',E12.5,'  LRAIN=',E12.5                     PHYSAV.44    
     :              ,'   RAIN=',E12.5,'   EVAP=',E12.5,' MM/DAY')          PHYSAV.45    
 6040 FORMAT(' ***PHYSAV : TIME SERIES OF PHYSICS GLOBAL AVERAGES'         PHYSAV.46    
     :      ,' ON PLOT FILE STOPS AT DAY',F10.2)                           PHYSAV.47    
C                                                                          PHYSAV.48    
C     Write header.  Preset time averages and set constants.               PHYSAV.49    
C                                                                          PHYSAV.50    
      IF (NPC9.NE.6) WRITE(NPC9,'(/////)')                                 PHYSAV.51    
      WRITE(6,'(/////)')                                                   PHYSAV.52    
      IF (LTAV) THEN                                                       PHYSAV.53    
         DO 10 K=1,NPH                                                     PHYSAV.54    
   10    PHMN(K,3)=0.                                                      PHYSAV.55    
      ENDIF                                                                PHYSAV.56    
      RTOF=WW*CLATNT*.001*1000./PI2                                        PHYSAV.57    
      REWIND NCGDG                                                         PHYSAV.58    
      NPTS9=0                                                              PHYSAV.59    
C                                                                          PHYSAV.60    
C     ----------------------------------------------------------------     PHYSAV.61    
C     Main loop over analysis times.  For JOUNT >= 0 read data from        PHYSAV.62    
C     channel NCGDG.  JOUNT<0 denotes end of series so process averages.   PHYSAV.63    
C                                                                          PHYSAV.64    
   20 READ(NCGDG) JOUNT,TDAY                                               PHYSAV.65    
      IF (JOUNT.EQ.-999.AND..NOT.LTAV) RETURN                              PHYSAV.66    
C                                                                          PHYSAV.67    
      IF (JOUNT.GE.0) THEN                                                 PHYSAV.68    
         IF (NPC9.NE.6) WRITE(NPC9,6000) TDAY                              PHYSAV.69    
         WRITE(6,6000) TDAY                                                PHYSAV.70    
         READ(NCGDG) ((PHMN(K,N),K=1,NPH),N=1,2)                           PHYSAV.71    
         IF (LTAV.AND.JOUNT.GT.KSTART) THEN                                PHYSAV.72    
            DO 30 K=1,NPH                                                  PHYSAV.73    
   30       PHMN(K,3)=PHMN(K,3)+FTAV*PHMN(K,2)                             PHYSAV.74    
         ENDIF                                                             PHYSAV.75    
         NMIN=1                                                            PHYSAV.76    
         NMAX=2                                                            PHYSAV.77    
      ELSE                                                                 PHYSAV.78    
         IF (NPC9.NE.6) WRITE(NPC9,6010)                                   PHYSAV.79    
         WRITE(6,6010)                                                     PHYSAV.80    
         NMIN=3                                                            PHYSAV.81    
         NMAX=3                                                            PHYSAV.82    
      ENDIF                                                                PHYSAV.83    
C                                                                          PHYSAV.84    
      DO 40 N=NMIN,NMAX                                                    PHYSAV.85    
      SSBL=PHMN(1,N)                                                       PHYSAV.86    
      SHBL=PHMN(2,N)                                                       PHYSAV.87    
      SLBL=PHMN(3,N)                                                       PHYSAV.88    
      RRCR=PHMN(4,N)                                                       PHYSAV.89    
      RRLR=PHMN(5,N)                                                       PHYSAV.90    
      RAIN=PHMN(6,N)                                                       PHYSAV.91    
      PREC=RAIN*RTOF                                                       PHYSAV.92    
      EVAP=SLBL/RTOF                                                       PHYSAV.93    
      IF (NPC9.NE.6) THEN                                                  PHYSAV.94    
         WRITE(NPC9,6020) TIMANN(N),SHBL,SLBL,PREC,SSBL                    PHYSAV.95    
         WRITE(NPC9,6030) TIMANN(N),RRCR,RRLR,RAIN,EVAP                    PHYSAV.96    
      ENDIF                                                                PHYSAV.97    
      WRITE(6,6020) TIMANN(N),SHBL,SLBL,PREC,SSBL                          PHYSAV.98    
      WRITE(6,6030) TIMANN(N),RRCR,RRLR,RAIN,EVAP                          PHYSAV.99    
   40 CONTINUE                                                             PHYSAV.100   
      IF (JOUNT.LT.0) GOTO 50                                              PHYSAV.101   
C                                                                          PHYSAV.102   
C     Copy values into time series array to be sorted and copied to        PHYSAV.103   
C     plot file below.                                                     PHYSAV.104   
C                                                                          PHYSAV.105   
      IF (LPHCOP.AND.NPTS9.LT.NPMAX9) THEN                                 PHYSAV.106   
         NPTS9=NPTS9+1                                                     PHYSAV.107   
         IF (NPTS9.EQ.NPMAX9) WRITE(6,6040) DAY                            PHYSAV.108   
         ADAY(NPTS9)=DAY                                                   PHYSAV.109   
         ADIAG(NPTS9,1)=PHMN(1,2)                                          PHYSAV.110   
         ADIAG(NPTS9,2)=PHMN(2,2)                                          PHYSAV.111   
         ADIAG(NPTS9,3)=PHMN(3,2)                                          PHYSAV.112   
         ADIAG(NPTS9,5)=PHMN(4,2)                                          PHYSAV.113   
         ADIAG(NPTS9,6)=PHMN(5,2)                                          PHYSAV.114   
         ADIAG(NPTS9,7)=PHMN(6,2)                                          PHYSAV.115   
         ADIAG(NPTS9,4)=ADIAG(NPTS9,7)*RTOF                                PHYSAV.116   
         ADIAG(NPTS9,8)=ADIAG(NPTS9,3)/RTOF                                PHYSAV.117   
      ENDIF                                                                PHYSAV.118   
C                                                                          PHYSAV.119   
      GOTO 20                                                              PHYSAV.120   
C                                                                          PHYSAV.121   
C     ----------------------------------------------------------------     PHYSAV.122   
C     End of loop over analysis times.                                     PHYSAV.123   
C     Write time series to file for plotting in subsequent job.            PHYSAV.124   
C                                                                          PHYSAV.125   
   50 IF (.NOT.LPHCOP) RETURN                                              PHYSAV.126   
      IANC=-1                                                              PHYSAV.127   
      XU=XUEN                                                              PHYSAV.128   
      YL=335.                                                              PHYSAV.129   
      IXT=3                                                                PHYSAV.130   
      IYT=3                                                                PHYSAV.131   
      I2=0                                                                 PHYSAV.132   
      DO 100 NPLOT=1,3                                                     PHYSAV.133   
      I1=I2+1                                                              PHYSAV.134   
      I2=I1+NI(NPLOT)-1                                                    PHYSAV.135   
      WRITE(IYLAB(NPLOT)(1:8),'(F8.3)')RNTAPE                              PHYSAV.136   
      NBEG=1                                                               PHYSAV.137   
      NEND=NBEG+ISPLIT                                                     PHYSAV.138   
   80 IF (NEND.GT.NPTS9) NEND=NPTS9                                        PHYSAV.139   
      XMN=ADAY(NBEG)                                                       PHYSAV.140   
      IF (NINT(XMN).EQ.1+NINT(KBEGP/TSPD)) XMN=0.                          PHYSAV.141   
      XL=ADAY(NEND)-XMN                                                    PHYSAV.142   
      IXI=NINT(XL)                                                         PHYSAV.143   
      XL=XL/XU                                                             PHYSAV.144   
      N=NEND-NBEG+1                                                        PHYSAV.145   
      LNPIC=.TRUE.                                                         SUNMOD.52    
      DO 90 I=I1,I2                                                        PHYSAV.147   
      LTEMP(4:6)=IDAN(I)                                                   PHYSAV.148   
      WRITE(NCPLOT(1)) N,IXT,IYT,LTEMP,IANC,IXLAB,IYLAB(NPLOT),XL,XU,XMN   PHYSAV.149   
     :         ,IXI,YL,ADMX(NPLOT),ADMN(NPLOT),IYD(NPLOT),LNPIC            PHYSAV.150   
      WRITE(NCPLOT(1)) (ADAY(K),K=NBEG,NEND),(ADIAG(K,I),K=NBEG,NEND)      PHYSAV.151   
   90 LNPIC=.FALSE.                                                        SUNMOD.53    
      NBEG=NEND                                                            PHYSAV.153   
      NEND=NBEG+ISPLIT                                                     PHYSAV.154   
      IF (NBEG.LT.NPTS9) GOTO 80                                           PHYSAV.155   
  100 CONTINUE                                                             PHYSAV.156   
C                                                                          PHYSAV.157   
      RETURN                                                               PHYSAV.158   
      END                                                                  PHYSAV.159   
C     ****************************************************************     PHYSAV.160   
*DECK LTEND                                                                LTEND.1     
      SUBROUTINE LTEND                                                     LTEND.2     
C                                                                          LTEND.3     
C     Calculate diabatic/frictional tendencies from linear processes.      LTEND.4     
C     Biharmonic diffusion : Restoration : Linear Drag.                    LTEND.5     
C                                                                          LTEND.6     
*CALL PARAM1                                                               LTEND.7     
*CALL PARAM2                                                               LTEND.8     
*CALL BATS                                                                 LTEND.9     
*CALL BLANK                                                                LTEND.10    
*CALL COMGEN                                                               LTEND.11    
*CALL SPECTR                                                               LTEND.12    
C                                                                          LTEND.13    
      DO 10 I=1,IGB,IGA                                                    LTEND.14    
   10 Z(I)=Z(I)-EZ                                                         LTEND.15    
C                                                                          LTEND.16    
      IG=0                                                                 LTEND.17    
      I=0                                                                  LTEND.18    
      DO 50 L=1,NL                                                         LTEND.19    
      TIDZT=0.                                                             LTEND.20    
      TIGZT=0.                                                             LTEND.21    
      TRKZT=0.                                                             LTEND.22    
      TRNZT=0.                                                             LTEND.23    
      TIDET=0.                                                             LTEND.24    
      TIGET=0.                                                             LTEND.25    
      TRNST=0.                                                             LTEND.26    
      TDRZT=0.                                                             LTEND.27    
      TDRET=0.                                                             LTEND.28    
      DO 40 IHEM=1,NHEM                                                    LTEND.29    
      JE=IHEM-1                                                            LTEND.30    
      JO=2-IHEM                                                            LTEND.31    
      IF (IHEM.EQ.1) TRNST=TRNST+REAL(T(IG+1)*(T(IG+1)-TRES(I+1)))         LTEND.32    
      DO 20 JP=1,NFP,MH                                                    LTEND.33    
      I=I+1                                                                LTEND.34    
      IG=IG+1                                                              LTEND.35    
      TIDZT=TIDZT+REAL(D(IG)*D(IG))*(SQ(JP+JE)**NDELHM)+REAL(Z(IG)*Z(IG)   LTEND.36    
     :)*(SQ(JP+JO)**NDELHM)                                                LTEND.37    
      TDRZT=TDRZT+REAL(D(IG)*D(IG))*DRAG(L)*RSQ(JP+JE)                     LTEND.38    
     :+REAL(Z(IG)*Z(IG))*DRAG(L)*RSQ(JP+JO)                                LTEND.39    
      TIGZT=TIGZT+REAL(T(IG)*T(IG))*(SQ(JP+JE)**NDELH)                     LTEND.40    
      TRNZT=TRNZT+REAL(T(IG)*(T(IG)-TRES(I)))                              LTEND.41    
   20 CONTINUE                                                             LTEND.42    
      DO 30 MP=MOCTP,MFP,MOCT                                              LTEND.43    
      DO 30 JP=MP,NFP,MH                                                   LTEND.44    
      IG=IG+1                                                              LTEND.45    
      TIDET=TIDET+REAL(D(IG)*CONJG(D(IG)))*(SQ(JP+JE)**NDELHM)+REAL(       LTEND.46    
     :Z(IG)*CONJG(Z(IG)))*(SQ(JP+JO)**NDELHM)                              LTEND.47    
      TDRET=TDRET+REAL(D(IG)*CONJG(D(IG)))*DRAG(L)*RSQ(JP+JE)              LTEND.48    
     :+REAL(Z(IG)*CONJG(Z(IG)))*DRAG(L)*RSQ(JP+JO)                         LTEND.49    
      TIGET=TIGET+REAL(T(IG)*CONJG(T(IG)))*(SQ(JP+JE)**NDELH)              LTEND.50    
   30 CONTINUE                                                             LTEND.51    
   40 CONTINUE                                                             LTEND.52    
      TIDZ(L)=.5*TIDZT                                                     LTEND.53    
      TIGZ(L)=.5*TIGZT                                                     LTEND.54    
      TRKZ(L)=.5*TRKZT                                                     LTEND.55    
      TRNZ(L)=.5*(TRNZT-TRNST)                                             LTEND.56    
      TRNS(L)=.5*TRNST                                                     LTEND.57    
      TDRZ(L)=.5*TDRZT                                                     LTEND.58    
      TDRE(L)=TDRET                                                        LTEND.59    
      TIDE(L)=TIDET                                                        LTEND.60    
      TIGE(L)=TIGET                                                        LTEND.61    
   50 CONTINUE                                                             LTEND.62    
C                                                                          LTEND.63    
      DO 60 I=1,IGB,IGA                                                    LTEND.64    
   60 Z(I)=Z(I)+EZ                                                         LTEND.65    
C                                                                          LTEND.66    
      RETURN                                                               LTEND.67    
      END                                                                  LTEND.68    
C     ****************************************************************     LTEND.69    
*DECK NSPECT                                                               NSPECT.1     
      SUBROUTINE NSPECT                                                    NSPECT.2     
C                                                                          NSPECT.3     
C     Calculate KE spectra over total wavenumber 'n' and over zonal        NSPECT.4     
C     wavenumber 'm' at current analysis time.                             NSPECT.5     
C        RKE(,,1) contains n-spectrum                                      NSPECT.6     
C        RKE(,,2) contains m-spectrum                                      NSPECT.7     
C     Print spectra and total eddy-KE.  Also write to plot files for       NSPECT.8     
C     plotting in subsequent job if LSPPLT=.TRUE.                          SUNMOD.54    
C        Channel NCPLOT(3) : copy of m-spectrum for time-series.           NSPECT.10    
C        Channel NCPLOT(2) : m-spectrum.                                   NSPECT.11    
C        Channel NCPLOT(1) : n-spectrum.                                   NSPECT.12    
C     NSPECT is also called at end of run with KOUNT < 0 to write a        NSPECT.13    
C     time-series of day numbers for plotting and to copy all plot-file    NSPECT.14    
C     data to channel NCPLOT(1).                                           NSPECT.15    
C     Time series of m-spectrum has maximum number of points given by      NSPECT.16    
C     parameter NPMAX4.                                                    NSPECT.17    
C                                                                          NSPECT.18    
*CALL PARAM1                                                               NSPECT.19    
*CALL PARAM2                                                               NSPECT.20    
*CALL BATS                                                                 NSPECT.21    
*CALL BLANK                                                                NSPECT.22    
*CALL COMIOC                                                               NSPECT.23    
*CALL OUTCON                                                               NSPECT.24    
*CALL SPEC                                                                 NSPECT.25    
*CALL SPECTR                                                               NSPECT.26    
      CHARACTER ICAN*8,IXLAB(2)*22,IYLAB*30                                NSPECT.27    
      SAVE ICAN,IXLAB,IYLAB                                                NSPECT.28    
C                                                                          NSPECT.29    
      DATA ICAN /'      *.'/                                               NSPECT.30    
      DATA IYLAB/'            KE PER UNIT AREA*.'/                         NSPECT.31    
      DATA IXLAB/'TOTAL WAVENUMBER (N)*.'                                  NSPECT.32    
     :          ,'ZONAL WAVENUMBER (M)*.'/                                 NSPECT.33    
C                                                                          NSPECT.34    
 6000 FORMAT(' PROCESSING KE M & N SPECTRA  AT DAY',F10.2,' KOUNT=',I10)   NSPECT.35    
 6010 FORMAT(/' TOTAL EDDY KE PER UNIT AREA (TKE) (JOULES/M2)',E13.5       NSPECT.36    
     :      //' KINETIC ENERGY SPECTRUM AS FUNCTION OF ',A20)              NSPECT.37    
 6020 FORMAT(1X,I6,I4,11(E11.4))                                           NSPECT.38    
 6030 FORMAT(' ***NSPECT: TIME SERIES PLOTS OF TKE AND M-SPECTRUM'         NSPECT.39    
     :      ,' STOP AT DAY',F10.2)                                         NSPECT.40    
C                                                                          NSPECT.41    
      IF (KOUNT.LT.0) GOTO 200                                             NSPECT.42    
C                                                                          NSPECT.43    
C     ----------------------------------------------------------------     NSPECT.44    
C     Calculate KE spectra for current analysis time.                      NSPECT.45    
C                                                                          NSPECT.46    
      IF (NPC4.NE.6) THEN                                                  NSPECT.47    
         WRITE(NPC4,'(///)')                                               NSPECT.48    
         WRITE(NPC4,6000) DAY,KOUNT                                        NSPECT.49    
      ENDIF                                                                NSPECT.50    
      WRITE(6,6000) DAY,KOUNT                                              NSPECT.51    
C                                                                          NSPECT.52    
      DO 10 II=1,2                                                         NSPECT.53    
      DO 10 L=1,NLP                                                        NSPECT.54    
      DO 10 N=2,NFPP                                                       NSPECT.55    
   10 RKE(N,L,II)=0.                                                       NSPECT.56    
C                                                                          NSPECT.57    
      MP=0                                                                 NSPECT.58    
      DO 20 M=1,MFPP,MOCT                                                  NSPECT.59    
      MP=MP+1                                                              NSPECT.60    
      DO 20 JP=M,NFPP                                                      NSPECT.61    
      ZL(JP,MP)=(0.,0.)                                                    NSPECT.62    
      DL(JP,MP)=(0.,0.)                                                    NSPECT.63    
   20 CONTINUE                                                             NSPECT.64    
C                                                                          NSPECT.65    
      IOLD=0                                                               NSPECT.66    
      DO 100 L=1,NL                                                        NSPECT.67    
C                                                                          NSPECT.68    
      DO 30 IHEM=1,NHEM                                                    NSPECT.69    
      MP=0                                                                 NSPECT.70    
      DO 30 M=1,MFP,MOCT                                                   NSPECT.71    
      MP=MP+1                                                              NSPECT.72    
      DO 30 JP=M,NFP,MH                                                    NSPECT.73    
      IOLD=IOLD+1                                                          NSPECT.74    
      DL(JP+IHEM-1,MP)=D(IOLD)                                             NSPECT.75    
      ZL(JP+2-IHEM,MP)=Z(IOLD)                                             NSPECT.76    
   30 CONTINUE                                                             NSPECT.77    
C                                                                          NSPECT.78    
      DO 50 N=2,NFPP                                                       NSPECT.79    
      IF (MOCTP.GT.N) GOTO 50                                              NSPECT.80    
      MP=1                                                                 NSPECT.81    
      MMAX=MIN0(N,MFP)                                                     NSPECT.82    
      DO 40 M=MOCTP,MMAX,MOCT                                              NSPECT.83    
      MP=MP+1                                                              NSPECT.84    
   40 RKE(N,L,1)=RKE(N,L,1)+(ZL(N,MP)*CONJG(ZL(N,MP))                      NSPECT.85    
     :                      +DL(N,MP)*CONJG(DL(N,MP)))/SQ(N)               NSPECT.86    
   50 CONTINUE                                                             NSPECT.87    
C                                                                          NSPECT.88    
      MN=1                                                                 NSPECT.89    
      DO 60 MP=MOCTP,MFP,MOCT                                              NSPECT.90    
      MN=MN+1                                                              NSPECT.91    
      DO 60 N=MP,NFPP                                                      NSPECT.92    
   60 RKE(MN,L,2)=RKE(MN,L,2)+(ZL(N,MN)*CONJG(ZL(N,MN))                    NSPECT.93    
     :                        +DL(N,MN)*CONJG(DL(N,MN)))/SQ(N)             NSPECT.94    
C                                                                          NSPECT.95    
  100 CONTINUE                                                             NSPECT.96    
C                                                                          NSPECT.97    
C     Set label values for plot-file records.                              NSPECT.98    
C                                                                          NSPECT.99    
      IF (LSPPLT) THEN                                                     NSPECT.100   
         IXT=4                                                             NSPECT.101   
         IYT=4                                                             NSPECT.102   
         IANC=1                                                            NSPECT.103   
         XL=300.                                                           NSPECT.104   
         XU=100.                                                           NSPECT.105   
         XMN=1.                                                            NSPECT.106   
         IXI=10                                                            NSPECT.107   
         YL=335.                                                           NSPECT.108   
         YMX=1.0E+6                                                        NSPECT.109   
         YMN=1.0E-6                                                        NSPECT.110   
         IYI=10                                                            NSPECT.111   
         WRITE(IYLAB(1:8),'(F8.3)') RNTAPE                                 NSPECT.112   
         WRITE(ICAN(4:6),'(I3)') NINT(DAY)                                 NSPECT.113   
      ENDIF                                                                NSPECT.114   
C                                                                          NSPECT.115   
C     Loop over spectra.  Set wavenumber limits, dimensionalise,           NSPECT.116   
C     calculate vertical integrals (make approximation surface             NSPECT.117   
C     pressure equal to P0), calculate total eddy-KE.                      NSPECT.118   
C     Print values and write to plot-files.                                NSPECT.119   
C                                                                          NSPECT.120   
      DO 150 II=1,2                                                        NSPECT.121   
C                                                                          NSPECT.122   
      IF (II.EQ.1) THEN                                                    NSPECT.123   
         MMAX=NFPP                                                         NSPECT.124   
         IF (2*(NN/2).EQ.NN.AND.2*(MOCT/2).EQ.MOCT) MMAX=NFP               NSPECT.125   
         NPTS=MMAX-MOCT                                                    NSPECT.126   
         MIN=MOCT                                                          NSPECT.127   
         MAX=MMAX-1                                                        NSPECT.128   
         INC=1                                                             NSPECT.129   
         MINE=MIN+1                                                        NSPECT.130   
         MAXE=MAX+1                                                        NSPECT.131   
         INCE=INC                                                          NSPECT.132   
      ELSE                                                                 NSPECT.133   
         MMAX=MN                                                           NSPECT.134   
         NPTS=MMAX-1                                                       NSPECT.135   
         MIN=MOCT                                                          NSPECT.136   
         MAX=MF                                                            NSPECT.137   
         INC=MOCT                                                          NSPECT.138   
         MINE=2                                                            NSPECT.139   
         MAXE=MMAX                                                         NSPECT.140   
         INCE=1                                                            NSPECT.141   
      ENDIF                                                                NSPECT.142   
C                                                                          NSPECT.143   
      DO 110 L=1,NL                                                        NSPECT.144   
      DO 110 N=2,MMAX                                                      NSPECT.145   
  110 RKE(N,L,II)=RKE(N,L,II)*RKEFAC                                       NSPECT.146   
C                                                                          NSPECT.147   
      DO 120 L=1,NL                                                        NSPECT.148   
      DO 120 N=2,MMAX                                                      NSPECT.149   
  120 RKE(N,NLP,II)=RKE(N,NLP,II)+RKE(N,L,II)*DSIGMA(L)                    NSPECT.150   
      TKEDDY=SSUM(MMAX-1,RKE(2,NLP,II),1)                                  NSPECT.151   
C                                                                          NSPECT.152   
      WRITE(NPC4,6010) TKEDDY,IXLAB(II)                                    NSPECT.153   
      DO 130 N=2,MMAX                                                      NSPECT.154   
      NM=(N-1)*INC                                                         NSPECT.155   
      WRITE(NPC4,6020) KOUNT,NM,(RKE(N,L,II),L=1,NLP)                      NSPECT.156   
  130 CONTINUE                                                             NSPECT.157   
C                                                                          NSPECT.158   
      IF (LSPPLT) THEN                                                     NSPECT.159   
         WRITE(NCPLOT(II)) NPTS,IXT,IYT,ICAN,IANC,IXLAB(II),IYLAB          NSPECT.160   
     :                    ,XL,XU,XMN,IXI,YL,YMX,YMN,IYI,LNPIC              NSPECT.161   
         WRITE(NCPLOT(II)) (RNWN(I),I=MIN,MAX,INC)                         NSPECT.162   
     :                    ,(RKE(I,NLP,II),I=MINE,MAXE,INCE)                NSPECT.163   
      ENDIF                                                                NSPECT.164   
C                                                                          NSPECT.165   
  150 CONTINUE                                                             NSPECT.166   
C                                                                          NSPECT.167   
C     Write copy of zonal wavenumber spectrum for time series.             NSPECT.168   
C                                                                          NSPECT.169   
      IF (LSPPLT.AND.NPTS4.LT.NPMAX4) THEN                                 NSPECT.170   
         NPTS4=NPTS4+1                                                     NSPECT.171   
         IF (NPTS4.EQ.NPMAX4) WRITE(6,6030) DAY                            NSPECT.172   
         EDAY(NPTS4)=DAY                                                   NSPECT.173   
         MAXE=1+MIN0(21,MF)/MOCT                                           NSPECT.174   
         WRITE(NCPLOT(3)) TKEDDY,(RKE(I,NLP,2),I=MINE,MAXE,INCE)           NSPECT.175   
         LNPIC=.FALSE.                                                     SUNMOD.55    
      ENDIF                                                                NSPECT.177   
C                                                                          NSPECT.178   
      RETURN                                                               NSPECT.179   
C                                                                          NSPECT.180   
C     ----------------------------------------------------------------     NSPECT.181   
C     End of run.  Copy all plot data from channels NCPLOT(2) and (3)      NSPECT.182   
C     to NCPLOT(1).  Immediately before data is copied from NCPLOT(3),     NSPECT.183   
C     write array of days for TKE time series.                             NSPECT.184   
C                                                                          NSPECT.185   
  200 IF (.NOT.LSPPLT) RETURN                                              NSPECT.186   
C                                                                          NSPECT.187   
      REWIND NCPLOT(2)                                                     NSPECT.188   
C                                                                          NSPECT.192   
      DUMY=0.                                                              NSPECT.193   
      IDUMY=0                                                              NSPECT.194   
      LNPIC=.TRUE.                                                         SUNMOD.56    
      N=NPTS4+10000                                                        NSPECT.196   
      IYT=4                                                                NSPECT.197   
      IXT=3                                                                BUGS5.3     
      IANC=-1                                                              BUGS5.4     
      XU=XUEN                                                              BUGS5.5     
      YL=335.                                                              BUGS5.6     
      YMX=1.0E+6                                                           NSPECT.198   
      YMN=1.0E-6                                                           NSPECT.199   
      WRITE(NCPLOT(1)) N,IXT,IYT,ICAN,IANC,IXLAB(2),IYLAB,DUMY,XU,DUMY     BUGS5.7     
     :                ,IDUMY,YL,YMX,YMN,IDUMY,LNPIC                        BUGS5.8     
      WRITE(NCPLOT(1)) MOCT,MF,ISPLIT,INT(RNTAPE)                          NSPECT.202   
      WRITE(NCPLOT(1)) (EDAY(K),K=1,NPTS4)                                 NSPECT.203   
C                                                                          NSPECT.204   
      REWIND NCPLOT(3)                                                     NSPECT.205   
C                                                                          NSPECT.209   
      RETURN                                                               NSPECT.210   
      END                                                                  NSPECT.211   
C     ****************************************************************     NSPECT.212   
*DECK OPCOEF                                                               OPCOEF.1     
      SUBROUTINE OPCOEF                                                    OPCOEF.2     
C                                                                          OPCOEF.3     
C     Print spectral coefficients for model level fields.                  OPCOEF.4     
C                                                                          OPCOEF.5     
*CALL PARAM1                                                               OPCOEF.6     
*CALL PARAM2                                                               OPCOEF.7     
      PARAMETER(NOUT=6)                                                    OPCOEF.8     
C                                                                          OPCOEF.9     
*CALL BATS                                                                 OPCOEF.10    
*CALL BLANK                                                                OPCOEF.11    
*CALL OUTCON                                                               OPCOEF.12    
*CALL SPECTR                                                               OPCOEF.13    
      CHARACTER NAME(NOUT)*50                                              OPCOEF.14    
      SAVE NAME                                                            OPCOEF.15    
C                                                                          OPCOEF.16    
      DATA (NAME(N),N=1,NOUT)/                                             OPCOEF.17    
     1 'RELATIVE VORTICITY   ON SIGMA=           NON-DIM  '                OPCOEF.18    
     2,'DIVERGENCE           ON SIGMA=           NON-DIM  '                OPCOEF.19    
     3,'PERT. TEMPERATURE    ON SIGMA=           NON-DIM  '                OPCOEF.20    
     4,'SPECIFIC HUMIDITY    ON SIGMA=           NON-DIM  '                OPCOEF.21    
     5,'DIABATIC HEATING     ON SIGMA=           NON-DIM  '                OPCOEF.22    
     6,'LOG(SURFACE PRESSURE)                    NON-DIM  '                OPCOEF.23    
     :/                                                                    OPCOEF.24    
C                                                                          OPCOEF.25    
 6000 FORMAT(' PROCESSING SPECTRAL COEFFS   AT DAY',F10.2,' KOUNT=',I10)   OPCOEF.26    
 6010 FORMAT(/' DAY',F10.2,'  NUMBER OF TIME STEPS COMPLETED =',I10)       OPCOEF.27    
 6020 FORMAT(/' SPECTRAL COEFFICIENTS'/4('   COEFF  AMPLITUDE   PHASE'))   OPCOEF.28    
 6030 FORMAT(1X,A)                                                         OPCOEF.29    
C                                                                          OPCOEF.30    
      IF (NPC1.NE.6) THEN                                                  OPCOEF.31    
         IF (LOUTP) WRITE(NPC1,'(///)')                                    OPCOEF.32    
         WRITE(NPC1,6000) DAY,KOUNT                                        OPCOEF.33    
      ENDIF                                                                OPCOEF.34    
      WRITE(6,6000) DAY,KOUNT                                              OPCOEF.35    
C                                                                          OPCOEF.36    
      DO 1 I=1,IGB,IGA                                                     OPCOEF.37    
    1 Z(I)=Z(I)-EZ                                                         OPCOEF.38    
      WRITE(NPC1,6020)                                                     OPCOEF.39    
      DO 10 L=1,NL                                                         OPCOEF.40    
      IF (.NOT.LSPO(L)) GOTO 10                                            OPCOEF.41    
      WRITE(NAME(1)(31:36),'(F6.4)') SIGMA(L)                              OPCOEF.42    
      WRITE(NPC1,6030) NAME(1)                                             OPCOEF.43    
      CALL WRSPS(Z(1+(L-1)*IGA),1)                                         OPCOEF.44    
   10 CONTINUE                                                             OPCOEF.45    
      DO 11 I=1,IGB,IGA                                                    OPCOEF.46    
   11 Z(I)=Z(I)+EZ                                                         OPCOEF.47    
C                                                                          OPCOEF.48    
      WRITE(NPC1,6010) DAY,KOUNT                                           OPCOEF.49    
      WRITE(NPC1,6020)                                                     OPCOEF.50    
      DO 20 L=1,NL                                                         OPCOEF.51    
      IF (.NOT.LSPO(L)) GOTO 20                                            OPCOEF.52    
      WRITE(NAME(2)(31:36),'(F6.4)') SIGMA(L)                              OPCOEF.53    
      WRITE(NPC1,6030) NAME(2)                                             OPCOEF.54    
      CALL WRSPS(D(1+(L-1)*IGA),2)                                         OPCOEF.55    
   20 CONTINUE                                                             OPCOEF.56    
C                                                                          OPCOEF.57    
      WRITE(NPC1,6010) DAY,KOUNT                                           OPCOEF.58    
      WRITE(NPC1,6020)                                                     OPCOEF.59    
      DO 30 L=1,NL                                                         OPCOEF.60    
      IF (.NOT.LSPO(L)) GOTO 30                                            OPCOEF.61    
      WRITE(NAME(3)(31:36),'(F6.4)') SIGMA(L)                              OPCOEF.62    
      WRITE(NPC1,6030) NAME(3)                                             OPCOEF.63    
      CALL WRSPS(T(1+(L-1)*IGA),2)                                         OPCOEF.64    
   30 CONTINUE                                                             OPCOEF.65    
C                                                                          OPCOEF.66    
      IF (.NOT.LDRY) THEN                                                  BUGS5.9     
         WRITE(NPC1,6010) DAY,KOUNT                                        BUGS5.10    
         WRITE(NPC1,6020)                                                  BUGS5.11    
         DO 40 L=1,NL                                                      BUGS5.12    
         IF (.NOT.LSPO(L)) GOTO 40                                         BUGS5.13    
         WRITE(NAME(4)(31:36),'(F6.4)') SIGMA(L)                           BUGS5.14    
         WRITE(NPC1,6030) NAME(4)                                          BUGS5.15    
         CALL WRSPS(Q(1+(L-1)*IGA),2)                                      BUGS5.16    
   40    CONTINUE                                                          BUGS5.17    
      ENDIF                                                                BUGS5.18    
C                                                                          OPCOEF.75    
      WRITE(NPC1,6010) DAY,KOUNT                                           OPCOEF.76    
      WRITE(NPC1,6020)                                                     OPCOEF.77    
      DO 50 L=1,NL                                                         OPCOEF.78    
      IF (.NOT.LSPO(L)) GOTO 50                                            OPCOEF.79    
      WRITE(NAME(5)(31:36),'(F6.4)') SIGMA(L)                              OPCOEF.80    
      WRITE(NPC1,6030) NAME(5)                                             OPCOEF.81    
      CALL WRSPS(H(1+(L-1)*IGA),2)                                         OPCOEF.82    
   50 CONTINUE                                                             OPCOEF.83    
C                                                                          OPCOEF.84    
      WRITE(NPC1,6010) DAY,KOUNT                                           OPCOEF.85    
      WRITE(NPC1,6020)                                                     OPCOEF.86    
      WRITE(NPC1,6030) NAME(6)                                             OPCOEF.87    
      CALL WRSPS(SP(1),2)                                                  OPCOEF.88    
C                                                                          OPCOEF.89    
      RETURN                                                               OPCOEF.90    
      END                                                                  OPCOEF.91    
C     ****************************************************************     OPCOEF.92    
*DECK WRSPS                                                                WRSPS.1     
      SUBROUTINE WRSPS(A,IA)                                               WRSPS.2     
C                                                                          WRSPS.3     
C     Print spectral coefficients for single field at a single level.      WRSPS.4     
C     Entry WRSPI is called from INITAL to write invariant data to         WRSPS.5     
C     character array COEFF and set up pointer and scaling arrays,         WRSPS.6     
C     to optimise the formatted output.                                    WRSPS.7     
C                                                                          WRSPS.8     
*CALL PARAM1                                                               WRSPS.9     
*CALL PARAM2                                                               WRSPS.10    
      PARAMETER(RAD=180./PI)                                               WRSPS.11    
C                                                                          WRSPS.12    
*CALL BLANK                                                                WRSPS.13    
*CALL OUTCON                                                               WRSPS.14    
      COMPLEX A(NWJ2),POLAR,Z                                              WRSPS.15    
      CHARACTER COEFF(NWJ2,2)*8                                            WRSPS.16    
      REAL FP(IGA)                                                         WRSPS.17    
      INTEGER IP(IGA)                                                      WRSPS.18    
      SAVE COEFF,FP,IP                                                     WRSPS.19    
C                                                                          WRSPS.20    
      DATA COEFF/MJP*' (  ,  )'/                                           WRSPS.21    
C                                                                          WRSPS.22    
      POLAR(Z)=CMPLX(ABS(Z),ATAN2(AIMAG(Z),REAL(Z)+1.0E-20)*RAD)           SUNMOD.90    
C                                                                          WRSPS.24    
C     ----------------------------------------------------------------     WRSPS.25    
C     Write cofficients using preset arrays and pointers.                  WRSPS.26    
C                                                                          WRSPS.27    
      IF (NHEM.EQ.1) THEN                                                  WRSPS.28    
         WRITE(NPC1,6000)(COEFF(I,IA),POLAR(A(IP(I))*FP(I)),I=1,INSPC)     WRSPS.29    
      ELSE                                                                 WRSPS.30    
         WRITE(NPC1,6000)(COEFF(I,2),POLAR(A(IP(I)+(2-IA)*NWJ2)*FP(I))     WRSPS.31    
     :   ,COEFF(I,1),POLAR(A(IP(I)+(IA-1)*NWJ2)*FP(I)),I=1,INSPC)          WRSPS.32    
      ENDIF                                                                WRSPS.33    
 6000 FORMAT(4(A8,E11.4,F8.2))                                             WRSPS.34    
C                                                                          WRSPS.35    
      RETURN                                                               WRSPS.36    
C                                                                          WRSPS.37    
C     ----------------------------------------------------------------     WRSPS.38    
      ENTRY WRSPI(A,IA)                                                    WRSPS.39    
C                                                                          WRSPS.40    
C     Initialise pointers for output resolution in full resolution         WRSPS.41    
C     spectral arrays.  Initialise character array with invariant data.    WRSPS.42    
C                                                                          WRSPS.43    
      I=0                                                                  WRSPS.44    
      IG=0                                                                 WRSPS.45    
      DO 20 MP=1,MFP,MOCT                                                  WRSPS.46    
      IF (MP.GT.NCOEFF) GOTO 30                                            WRSPS.47    
      IBEG=IG                                                              WRSPS.48    
      DO 10 JP=MP,NCOEFF,MH                                                WRSPS.49    
      I=I+1                                                                WRSPS.50    
      IG=IG+1                                                              WRSPS.51    
      IP(I)=IG                                                             WRSPS.52    
      IF (MP.EQ.1) THEN                                                    SUNMOD.83    
        FP(I)=1.                                                           SUNMOD.84    
       ELSE                                                                SUNMOD.85    
        FP(I)=2.                                                           SUNMOD.86    
       ENDIF                                                               SUNMOD.87    
      WRITE(COEFF(I,1)(3:4),'(I2)')MP-1                                    WRSPS.54    
      WRITE(COEFF(I,2)(3:4),'(I2)')MP-1                                    WRSPS.55    
      WRITE(COEFF(I,1)(6:7),'(I2)')JP                                      WRSPS.56    
      WRITE(COEFF(I,2)(6:7),'(I2)')JP-1                                    WRSPS.57    
   10 CONTINUE                                                             WRSPS.58    
      IG=IBEG+(NFP-MP+2)/MH                                                WRSPS.59    
   20 CONTINUE                                                             WRSPS.60    
   30 CONTINUE                                                             WRSPS.61    
C                                                                          WRSPS.62    
      RETURN                                                               WRSPS.63    
      END                                                                  WRSPS.64    
C     ****************************************************************     WRSPS.65    
*DECK LTI                                                                  LTI.1     
      SUBROUTINE LTI                                                       LTI.2     
C                                                                          LTI.3     
C     Inverse Legendre transform, from spectral to Fourier space.          LTI.4     
C     HEXP transforms fields having the same symmetry and type of          LTI.5     
C     polynomial (ALP, DALP, RLP, RDLP etc).                               LTI.6     
C                                                                          LTI.7     
*CALL PARAM1                                                               LTI.8     
*CALL PARAM2                                                               LTI.9     
*CALL BLANK                                                                LTI.10    
*CALL GRIDP                                                                LTI.11    
*CALL POLYNO                                                               LTI.12    
*CALL SPECTR                                                               LTI.13    
      COMPLEX CUG(IGK),CVG(IGK),CSFG(IGK)                                  LTI.14    
     :,CTPG(IGL*NLP),CTPXG(IGL*NLP)                                        LTI.15    
      EQUIVALENCE (CUG(1),UG(1)),(CVG(1),VG(1)),(CSFG(1),SFG(1))           LTI.16    
     :,(CTPG(1),TG(1)),(CTPXG(1),TXG(1))                                   LTI.17    
C                                                                          LTI.18    
C     Absolute vorticity. Remove planetary vorticity for subsequent        LTI.19    
C     transforms requiring relative vorticity.                             LTI.20    
C                                                                          LTI.21    
      CALL HEXP(Z,ZG,NL,1)                                                 LTI.22    
      DO 10 I=1,IGB,IGA                                                    LTI.23    
   10 Z(I)=Z(I)-EZ                                                         LTI.24    
C                                                                          LTI.25    
C     Wind components.  Calls to HEXP give following Fourier fields:       LTI.26    
C        UG   :   -U(rot).                                                 LTI.27    
C        VG   :   V(div).                                                  LTI.28    
C        SFG  :   streamfunction.                                          LTI.29    
C        TG   :   velocty-potential.  (Temporary - overwritten below).     LTI.30    
C     Then sum to give total winds.  CMPA takes x-derivative.              LTI.31    
C                                                                          LTI.32    
      CALL HEXP(Z,UG ,NL,7)                                                LTI.33    
      CALL HEXP(Z,SFG,NL,5)                                                LTI.34    
      CALL HEXP(D,TG ,NL,6)                                                LTI.35    
      CALL HEXP(D,VG ,NL,8)                                                LTI.36    
      II=0                                                                 LTI.37    
      DO 20 L=1,NL                                                         LTI.38    
      DO 20 I=1,IGL                                                        LTI.39    
      II=II+1                                                              LTI.40    
      CUG(II)=CTPG(II)*CMPA(I)-CUG(II)                                     LTI.41    
      CVG(II)=CSFG(II)*CMPA(I)+CVG(II)                                     LTI.42    
   20 CONTINUE                                                             LTI.43    
C                                                                          LTI.44    
C     Symmetric spectral fields and their derivatives (D,Q,H,T,SP).        LTI.45    
C                                                                          LTI.46    
      CALL HEXP(D,DG,4*NL+1,2)                                             LTI.47    
      CALL HEXP(T,TYG,NLP,4)                                               LTI.48    
      II=0                                                                 LTI.49    
      DO 30 L=1,NLP                                                        LTI.50    
      DO 30 I=1,IGL                                                        LTI.51    
      II=II+1                                                              LTI.52    
   30 CTPXG(II)=CTPG(II)*CMPA(I)                                           LTI.53    
C                                                                          LTI.54    
      DO 40 I=1,IGB,IGA                                                    LTI.55    
   40 Z(I)=Z(I)+EZ                                                         LTI.56    
C                                                                          LTI.57    
      RETURN                                                               LTI.58    
      END                                                                  LTI.59    
C     ****************************************************************     LTI.60    
*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    
 6900 FORMAT(/' ***ABORT : HEXP CALLED WITH TYPE =',I5)                    HEXP.24    
C                                                                          HEXP.25    
C                                                                          HEXP.26    
C     Preset Fourier array to zero.                                        HEXP.27    
C                                                                          HEXP.28    
      DO 10 I=1,IGL*NLS                                                    HEXP.29    
   10 GV(I)=0.                                                             HEXP.30    
C                                                                          HEXP.31    
C     Use ITYPE to define transform type and symmetry labels.              HEXP.32    
C     ISPAR is symmetry of spectral field    = 0 for D,T,SP etc.           HEXP.33    
C                                            = 1 for Z.                    HEXP.34    
C     IGPAR is symmetry of Fourier field: same as ISPAR unless transform   HEXP.35    
C                                         involves a d/dy.                 HEXP.36    
C                                                                          HEXP.37    
      IF (ITYPE.LE.0.OR.ITYPE.GE.9) THEN                                   HEXP.38    
         WRITE(6,6900) ITYPE                                               HEXP.39    
         CALL ABORT                                                        HEXP.40    
      ENDIF                                                                HEXP.41    
      IALP=(ITYPE+1)/2                                                     HEXP.42    
      ISPAR=MOD(ITYPE,2)                                                   HEXP.43    
      IGPAR=ISPAR                                                          HEXP.44    
      IF (IALP.EQ.2.OR.IALP.EQ.4) IGPAR=1-ISPAR                            HEXP.45    
C                                                                          HEXP.46    
C     Calculate POLY array in vector loop before main transform.           HEXP.47    
C                                                                          HEXP.48    
      DO 30 IHEM=1,NHEM                                                    HEXP.49    
      INC=(IHEM-1)*(1-ISPAR)+(2-IHEM)*ISPAR                                HEXP.50    
      IA=INC-1                                                             HEXP.51    
      DO 20 IP=1,NWJ2                                                      HEXP.52    
      IA=IA+2                                                              HEXP.53    
   20 POLY(IP,IHEM)=ALPN(IA,JL,IALP)                                       HEXP.54    
   30 CONTINUE                                                             HEXP.55    
C                                                                          HEXP.56    
C     Perform inverse Legendre transform from spectral space to form       HEXP.57    
C     the even and odd contributions to the Fourier transforms.            HEXP.58    
C     Separate code for NHEM=1,2 to increase efficiency.                   HEXP.59    
C                                                                          HEXP.60    
      IF (NHEM.EQ.1) THEN                                                  HEXP.61    
         IM=-IDL                                                           HEXP.62    
         IP=-NWJ2                                                          HEXP.63    
         DO 40 MP=1,MFP,MOCT                                               HEXP.64    
         IM=IM+1                                                           HEXP.65    
         DO 40 IN=MP,NFP,MH                                                HEXP.66    
         IP=IP+1                                                           HEXP.67    
         DO 40 IV=1,NLS                                                    HEXP.68    
   40    GV(IM+IV*IDL)=GV(IM+IV*IDL) + POLY(IP+NWJ2,1)*SV(IP+IV*NWJ2)      HEXP.69    
      ELSE                                                                 HEXP.70    
         IM=-IDL                                                           HEXP.71    
         IP=-NWJ2                                                          HEXP.72    
         DO 50 MP=1,MFP,MOCT                                               HEXP.73    
         IM=IM+1                                                           HEXP.74    
         DO 50 IN=MP,NFP,MH                                                HEXP.75    
         IP=IP+1                                                           HEXP.76    
CDIR$    IVDEP                                                             BUGS5.19    
         DO 50 IV=1,NLS*NHEM,2                                             BUGS5.20    
         IW=IV+1                                                           BUGS5.21    
         GV(IM+IV*IDL)=GV(IM+IV*IDL) + POLY(IP+NWJ2,1)*SV(IP+IV*NWJ2)      BUGS5.22    
   50    GV(IM+IW*IDL)=GV(IM+IW*IDL) + POLY(IP+NWJ2,2)*SV(IP+IW*NWJ2)      BUGS5.23    
      ENDIF                                                                HEXP.80    
C                                                                          HEXP.81    
C     For a global run, sum and difference even and odd contributions      HEXP.82    
C     to give the complete Fourier transforms at the northern and          HEXP.83    
C     southern latitude rows.  Separate code for each symmetry:            HEXP.84    
C        IGPAR=0 : even (IA) precedes odd (IB).                            HEXP.85    
C        IGPAR=0 : odd (IA) precedes even (IB).                            HEXP.86    
C                                                                          HEXP.87    
      IF (NHEM.EQ.2) THEN                                                  HEXP.88    
         IF (IGPAR.EQ.0) THEN                                              HEXP.89    
            DO 60 M=1,NWW                                                  HEXP.90    
            IA=M-IGL                                                       HEXP.91    
CDIR$ IVDEP                                                                HEXP.92    
            DO 60 IV=1,NLS                                                 HEXP.93    
            IA=IA+IGL                                                      HEXP.94    
            IB=IA+IDL                                                      HEXP.95    
            TEMP=GV(IA)                                                    HEXP.96    
            GV(IA)=TEMP+GV(IB)                                             HEXP.97    
            GV(IB)=TEMP-GV(IB)                                             HEXP.98    
   60       CONTINUE                                                       HEXP.99    
         ELSE                                                              HEXP.100   
            DO 70 M=1,NWW                                                  HEXP.101   
            IA=M-IGL                                                       HEXP.102   
CDIR$ IVDEP                                                                HEXP.103   
            DO 70 IV=1,NLS                                                 HEXP.104   
            IA=IA+IGL                                                      HEXP.105   
            IB=IA+IDL                                                      HEXP.106   
            TEMP=GV(IA)                                                    HEXP.107   
            GV(IA)=GV(IB)+TEMP                                             HEXP.108   
            GV(IB)=GV(IB)-TEMP                                             HEXP.109   
   70       CONTINUE                                                       HEXP.110   
         ENDIF                                                             HEXP.111   
      ENDIF                                                                HEXP.112   
C                                                                          HEXP.113   
      RETURN                                                               HEXP.114   
      END                                                                  HEXP.115   
C     ****************************************************************     HEXP.116   
*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    
 6900 FORMAT(/' ***ABORT : HANAL CALLED WITH TYPE =',I5)                   HANAL.22    
C                                                                          HANAL.23    
C     Use ITYPE to define transform type and symmetry labels.              HANAL.24    
C     ISPAR is symmetry of spectral field    = 0 for D,T,SP etc.           HANAL.25    
C                                            = 1 for Z.                    HANAL.26    
C     IGPAR is symmetry of Fourier field: same as ISPAR unless transform   HANAL.27    
C                                         involves a d/dy.                 HANAL.28    
C                                                                          HANAL.29    
      IF (ITYPE.LE.0.OR.ITYPE.GE.5) THEN                                   HANAL.30    
         WRITE(6,6900) ITYPE                                               HANAL.31    
         CALL ABORT                                                        HANAL.32    
      ENDIF                                                                HANAL.33    
      IALP=(ITYPE+1)/2                                                     HANAL.34    
      ISPAR=MOD(ITYPE,2)                                                   HANAL.35    
      IGPAR=ISPAR                                                          HANAL.36    
      IF (IALP.EQ.2) IGPAR=1-ISPAR                                         HANAL.37    
C                                                                          HANAL.38    
C     For a global run, sum and difference the complete Fourier            HANAL.39    
C     transforms at the northern and southern latitude rows to give        HANAL.40    
C     the even and odd contributions.                                      HANAL.41    
C     Separate code for each symmetry:                                     HANAL.42    
C        IGPAR=0 : even (IA) to precede odd (IB).                          HANAL.43    
C        IGPAR=0 : odd (IA) to precede even (IB).                          HANAL.44    
C                                                                          HANAL.45    
      IF (NHEM.EQ.2) THEN                                                  HANAL.46    
         IF (IGPAR.EQ.0) THEN                                              HANAL.47    
            DO 10 M=1,NWW                                                  HANAL.48    
            IA=M-IGL                                                       HANAL.49    
CDIR$ IVDEP                                                                HANAL.50    
            DO 10 IV=1,NLS                                                 HANAL.51    
            IA=IA+IGL                                                      HANAL.52    
            IB=IA+IDL                                                      HANAL.53    
            TEMP=GV(IA)                                                    HANAL.54    
            GV(IA)=.5*(TEMP+GV(IB))                                        HANAL.55    
            GV(IB)=.5*(TEMP-GV(IB))                                        HANAL.56    
   10       CONTINUE                                                       HANAL.57    
         ELSE                                                              HANAL.58    
            DO 20 M=1,NWW                                                  HANAL.59    
            IA=M-IGL                                                       HANAL.60    
CDIR$ IVDEP                                                                HANAL.61    
            DO 20 IV=1,NLS                                                 HANAL.62    
            IA=IA+IGL                                                      HANAL.63    
            IB=IA+IDL                                                      HANAL.64    
            TEMP=GV(IA)                                                    HANAL.65    
            GV(IA)=.5*(TEMP-GV(IB))                                        HANAL.66    
            GV(IB)=.5*(TEMP+GV(IB))                                        HANAL.67    
   20       CONTINUE                                                       HANAL.68    
         ENDIF                                                             HANAL.69    
      ENDIF                                                                HANAL.70    
C                                                                          HANAL.71    
C     Set up appropriate Gaussian weight for current latitude.             HANAL.72    
C     Depends on transform type.                                           HANAL.73    
C     Assumes JH in /LEGAU/ contains latitude counter from calling loop.   HANAL.74    
C                                                                          HANAL.75    
      IF (IALP.EQ.1) AWT=AW(JH)*CSSQ(JH)                                   HANAL.76    
      IF (IALP.EQ.2) AWT=-AW(JH)                                           HANAL.77    
C                                                                          HANAL.78    
C     Calculate POLY array in vector loop before main transform.           HANAL.79    
C                                                                          HANAL.80    
      DO 30 IHEM=1,NHEM                                                    HANAL.81    
      INC=(IHEM-1)*(1-ISPAR)+(2-IHEM)*ISPAR                                HANAL.82    
      IA=INC-1                                                             HANAL.83    
      DO 30 IP=1,NWJ2                                                      HANAL.84    
      IA=IA+2                                                              HANAL.85    
   30 POLY(IP,IHEM)=AWT*ALPN(IA,JL,IALP)                                   HANAL.86    
C                                                                          HANAL.87    
C     Perform direct Legendre transform from the even and odd              HANAL.88    
C     parts of the Fourier transforms to spectral space.                   HANAL.89    
C     Separate code for NHEM=1,2 to increase efficiency.                   HANAL.90    
C                                                                          HANAL.91    
      IF (NHEM.EQ.1) THEN                                                  HANAL.92    
         IM=-IDL                                                           HANAL.93    
         IP=-NWJ2                                                          HANAL.94    
         DO 40 MP=1,MFP,MOCT                                               HANAL.95    
         IM=IM+1                                                           HANAL.96    
         DO 40 IN=MP,NFP,MH                                                HANAL.97    
         IP=IP+1                                                           HANAL.98    
         DO 40 IV=1,NLS                                                    HANAL.99    
   40    SV(IP+IV*NWJ2)=SV(IP+IV*NWJ2) + POLY(IP+NWJ2,1)*GV(IM+IV*IDL)     HANAL.100   
      ELSE                                                                 HANAL.101   
         IM=-IDL                                                           HANAL.102   
         IP=-NWJ2                                                          HANAL.103   
         DO 50 MP=1,MFP,MOCT                                               HANAL.104   
         IM=IM+1                                                           HANAL.105   
         DO 50 IN=MP,NFP,MH                                                HANAL.106   
         IP=IP+1                                                           HANAL.107   
CDIR$    IVDEP                                                             BUGS5.24    
         DO 50 IV=1,NLS*NHEM,2                                             BUGS5.25    
         IW=IV+1                                                           BUGS5.26    
         SV(IP+IV*NWJ2)=SV(IP+IV*NWJ2) + POLY(IP+NWJ2,1)*GV(IM+IV*IDL)     BUGS5.27    
   50    SV(IP+IW*NWJ2)=SV(IP+IW*NWJ2) + POLY(IP+NWJ2,2)*GV(IM+IW*IDL)     BUGS5.28    
      ENDIF                                                                HANAL.111   
C                                                                          HANAL.112   
      RETURN                                                               HANAL.113   
      END                                                                  HANAL.114   
C     ****************************************************************     HANAL.115   
*DECK GRMULT                                                               GRMULT.1     
      SUBROUTINE GRMULT                                                    GRMULT.2     
C                                                                          GRMULT.3     
C     Control routine for all grid point calculations in main loop.        GRMULT.4     
C     JH in common LEGAU contains latitude row number.                     GRMULT.5     
C                                                                          GRMULT.6     
*CALL PARAM1                                                               GRMULT.7     
*CALL PARAM2                                                               GRMULT.8     
*CALL BATS                                                                 GRMULT.9     
*CALL BLANK                                                                GRMULT.10    
*CALL COMGRM                                                               GRMULT.11    
*CALL COMPRL                                                               GRMULT.12    
*CALL GRIDP                                                                GRMULT.13    
*CALL OUTCON                                                               GRMULT.14    
C                                                                          GRMULT.15    
C     Full fields of non-dimensional temperature and surface pressure.     GRMULT.16    
C                                                                          GRMULT.17    
      DO 10 I=1,IGC                                                        GRMULT.18    
   10 PLG(I)=EXP(PLG(I))                                                   GRMULT.19    
      K=0                                                                  GRMULT.20    
      DO 20 L=1,NL                                                         GRMULT.21    
      DO 20 I=1,IGC                                                        GRMULT.22    
      K=K+1                                                                GRMULT.23    
      TG(K)=TG(K)+TMEAN(L)                                                 GRMULT.24    
   20 CONTINUE                                                             GRMULT.25    
C                                                                          GRMULT.26    
C     Model level pressures.                                               GRMULT.27    
      CALL PSGCR                                                           GRMULT.28    
C                                                                          GRMULT.29    
C     Non-linear parameterised momentum tendencies.                        GRMULT.30    
      CALL NTEND                                                           GRMULT.31    
C                                                                          GRMULT.32    
C     Geopotential height.                                                 GRMULT.33    
      CALL GHGCR                                                           GRMULT.34    
C                                                                          GRMULT.35    
C     Omega.                                                               GRMULT.36    
      CALL OMGCR                                                           GRMULT.37    
C                                                                          GRMULT.38    
C     MSL pressure and surface fields used for extrapolation.              GRMULT.39    
      CALL SRFCR                                                           GRMULT.40    
C                                                                          GRMULT.41    
C     Vertical derivative terms.                                           GRMULT.42    
      IF (LINTP2.OR.(LPC6.AND.LOUT)) THEN                                  GRMULT.43    
         CALL DLSGCR(IGC,UG,RGG,DUDLSG,IGC,NL)                             GRMULT.44    
         CALL DLSGCR(IGC,VG,RGG,DVDLSG,IGC,NL)                             GRMULT.45    
         CALL DLSGCR(IGC,TG,RGG,DTDLSG,IGC,NL)                             GRMULT.46    
      ENDIF                                                                GRMULT.47    
C                                                                          GRMULT.48    
C     Ertel potential vorticity and interpolation to isentropic levels.    GRMULT.49    
      IF (LPC6.AND.LOUT) CALL PVCR                                         GRMULT.50    
C                                                                          GRMULT.51    
C     Interpolation to isobaric levels if required.                        GRMULT.52    
      IF (LINTP2) THEN                                                     GRMULT.53    
         CALL DVPCOR                                                       GRMULT.54    
         CALL INTPR                                                        GRMULT.55    
      ENDIF                                                                GRMULT.56    
C                                                                          GRMULT.57    
      RETURN                                                               GRMULT.58    
      END                                                                  GRMULT.59    
C     ****************************************************************     GRMULT.60    
*DECK PSGCR                                                                PSGCR.1     
      SUBROUTINE PSGCR                                                     PSGCR.2     
C                                                                          PSGCR.3     
C     Calculate pressures on full model levels.                            PSGCR.4     
C     Find max and min pressure for each level / latitude row.             PSGCR.5     
C     Reading model - trivial for sigma co-ords.                           PSGCR.6     
C                                                                          PSGCR.7     
*CALL PARAM1                                                               PSGCR.8     
*CALL PARAM2                                                               PSGCR.9     
*CALL BLANK                                                                PSGCR.10    
*CALL COMPRL                                                               PSGCR.11    
*CALL GRIDP                                                                PSGCR.12    
      DO 30 L=1,NL                                                         PSGCR.13    
      DO 10 II=1,IGC                                                       PSGCR.14    
   10 PSG(II,L)=SIGMA(L)*PLG(II)                                           PSGCR.15    
      DO 20 IHEM=1,NHEM                                                    PSGCR.16    
      IOF=(IHEM-1)*MGPP                                                    PSGCR.17    
      IM=ISMAX(MG,PSG(IOF+1,L),1)                                          PSGCR.18    
      PSGMX(L,IHEM)=PSG(IOF+IM,L)                                          PSGCR.19    
      IM=ISMIN(MG,PSG(IOF+1,L),1)                                          PSGCR.20    
      PSGMN(L,IHEM)=PSG(IOF+IM,L)                                          PSGCR.21    
   20 CONTINUE                                                             PSGCR.22    
   30 CONTINUE                                                             PSGCR.23    
C                                                                          PSGCR.24    
      RETURN                                                               PSGCR.25    
      END                                                                  PSGCR.26    
C     ****************************************************************     PSGCR.27    
*DECK NTEND                                                                NTEND.1     
      SUBROUTINE NTEND                                                     NTEND.2     
C                                                                          NTEND.3     
C     Calculate non-linear momentum tendencies from boundary layer and     NTEND.4     
C     vertical diffusion schemes, if included.  Used in GDIAG for          NTEND.5     
C     global energetics, plus fields may also be printed/plotted.          NTEND.6     
C     Applies parameterisation schemes from the simple GCM (SGCM)          NTEND.7     
C     PDN=BGCM5,ID=UPLIB,ED=5 to the history file data at the current      NTEND.8     
C     analysis time.  Note that the tendencies in the model are slightly   NTEND.9     
C     different since they are computed in a split timestep there.         NTEND.10    
C                                                                          NTEND.11    
*CALL PARAM1                                                               NTEND.12    
*CALL PARAM2                                                               NTEND.13    
*CALL BATS                                                                 NTEND.14    
*CALL BLANK                                                                NTEND.15    
*CALL GRIDP                                                                NTEND.16    
*CALL LEGAU                                                                NTEND.17    
*CALL PHYS                                                                 NTEND.18    
      REAL FA(NL),BVP(MG),BVM(MG)                                          NTEND.19    
C                                                                          NTEND.20    
C     Zero presets.  No calculations if parameterisations not switched     NTEND.21    
C     on at current analysis time.                                         NTEND.22    
C                                                                          NTEND.23    
      DO 10 I=1,IGD                                                        NTEND.24    
      FUG(I)=0.0                                                           NTEND.25    
      FVG(I)=0.0                                                           NTEND.26    
   10 CONTINUE                                                             NTEND.27    
      IF (KOUNT.LE.KBEGP) RETURN                                           NTEND.28    
C                                                                          NTEND.29    
C     Boundary layer scheme.                                               NTEND.30    
C     Momentum tendencies at lowest model level associated with surface    NTEND.31    
C     fluxes.  Bulk aerodynamic formula without stability dependence.      NTEND.32    
C                                                                          NTEND.33    
      IF (LBL) THEN                                                        NTEND.34    
      DO 30 IHEM=1,NHEM                                                    NTEND.35    
      JOF=NLM*IGC + (IHEM-1)*MGPP                                          NTEND.36    
      BLCONJ=BLCON/TSTAR(JH,IHEM)                                          NTEND.37    
      DO 20 I=1,MG                                                         NTEND.38    
      J=JOF+I                                                              NTEND.39    
      VM=SQRT(SECSQ(JH)*(UG(J)*UG(J)+VG(J)*VG(J)))                         NTEND.40    
      CMODV=BLCONJ*(VM+BLVAD)                                              NTEND.41    
      FUG(J)=FUG(J)-CMODV*UG(J)                                            NTEND.42    
      FVG(J)=FVG(J)-CMODV*VG(J)                                            NTEND.43    
   20 CONTINUE                                                             NTEND.44    
   30 CONTINUE                                                             NTEND.45    
      ENDIF                                                                NTEND.46    
C                                                                          NTEND.47    
C     Vertical diffusion scheme.                                           NTEND.48    
C     Linear diffusive flux throughout model depth with constant coeff.    NTEND.49    
C                                                                          NTEND.50    
      IF (LVD) THEN                                                        NTEND.51    
      DO 100 L=1,NL                                                        NTEND.52    
  100 FA(L)=1.0/DSIGMA(L)                                                  NTEND.53    
      DO 140 IHEM=1,NHEM                                                   NTEND.54    
      IOFM=(IHEM-1)*MGPP                                                   NTEND.55    
      DO 110 I=1,MG                                                        NTEND.56    
      J=I+IOFM                                                             NTEND.57    
      JP=J+IGC                                                             NTEND.58    
      TLPH=TG(JP)+TG(J)                                                    NTEND.59    
      FTSQ=FB(1)/(TLPH*TLPH)                                               NTEND.60    
      BVP(I)=AKVV*FTSQ                                                     NTEND.61    
      FUG(J)=FUG(J)+FA(1)*BVP(I)*(UG(JP)-UG(J))                            NTEND.62    
      FVG(J)=FVG(J)+FA(1)*BVP(I)*(VG(JP)-VG(J))                            NTEND.63    
  110 CONTINUE                                                             NTEND.64    
      DO 120 L=2,NLM                                                       NTEND.65    
      JOF=(L-1)*IGC+IOFM                                                   NTEND.66    
      DO 120 I=1,MG                                                        NTEND.67    
      J=JOF+I                                                              NTEND.68    
      JP=J+IGC                                                             NTEND.69    
      JM=J-IGC                                                             NTEND.70    
      BVM(I)=BVP(I)                                                        NTEND.71    
      TLPH=TG(JP)+TG(J)                                                    NTEND.72    
      FTSQ=FB(L)/(TLPH*TLPH)                                               NTEND.73    
      BVP(I)=AKVV*FTSQ                                                     NTEND.74    
      FUG(J)=FUG(J)+FA(L)*(BVP(I)*(UG(JP)-UG(J))-BVM(I)*(UG(J)-UG(JM)))    NTEND.75    
      FVG(J)=FVG(J)+FA(L)*(BVP(I)*(VG(JP)-VG(J))-BVM(I)*(VG(J)-VG(JM)))    NTEND.76    
  120 CONTINUE                                                             NTEND.77    
      JOF=NLM*IGC+IOFM                                                     NTEND.78    
      DO 130 I=1,MG                                                        NTEND.79    
      J=JOF+I                                                              NTEND.80    
      JM=J-IGC                                                             NTEND.81    
      FUG(J)=FUG(J)-FA(NL)*BVP(I)*(UG(J)-UG(JM))                           NTEND.82    
      FVG(J)=FVG(J)-FA(NL)*BVP(I)*(VG(J)-VG(JM))                           NTEND.83    
  130 CONTINUE                                                             NTEND.84    
  140 CONTINUE                                                             NTEND.85    
      ENDIF                                                                NTEND.86    
C                                                                          NTEND.87    
      RETURN                                                               NTEND.88    
      END                                                                  NTEND.89    
C     ****************************************************************     NTEND.90    
*DECK GHGCR                                                                GHGCR.1     
      SUBROUTINE GHGCR                                                     GHGCR.2     
C                                                                          GHGCR.3     
C     Compute geopotential height field.  Integrate hydrostatic            GHGCR.4     
C     equation and add orography if non-zero.  Resulting array GHG         GHGCR.5     
C     is geopotential non-dimensionalsed by CG.                            GHGCR.6     
C     NB. Called from GRMULT so TG contains full temperature inc TMEAN.    GHGCR.7     
C     Reading model - sigma.                                               GHGCR.8     
C                                                                          GHGCR.9     
*CALL PARAM1                                                               GHGCR.10    
*CALL PARAM2                                                               GHGCR.11    
*CALL BATS                                                                 GHGCR.12    
*CALL BLANK                                                                GHGCR.13    
*CALL COMROG                                                               GHGCR.14    
*CALL GRIDP                                                                GHGCR.15    
*CALL LEGAU                                                                GHGCR.16    
C                                                                          GHGCR.17    
C     Zero preset.                                                         GHGCR.18    
C                                                                          GHGCR.19    
      DO 10 I=1,IGD                                                        GHGCR.20    
   10 GHG(I)=0.                                                            GHGCR.21    
C                                                                          GHGCR.22    
C     Integrate hydrostatic equation.                                      GHGCR.23    
C                                                                          GHGCR.24    
      IL=0                                                                 GHGCR.25    
      DO 20 L=1,NL                                                         GHGCR.26    
      DO 20 K=1,NL                                                         GHGCR.27    
      IL=IL+1                                                              GHGCR.28    
      GG=G(IL)                                                             GHGCR.29    
      DO 20 IHEM=1,NHEM                                                    GHGCR.30    
      II=(L-1)*IGC+(IHEM-1)*MGPP                                           GHGCR.31    
      IKK=(K-1)*IGC+(IHEM-1)*MGPP                                          GHGCR.32    
      DO 20 I=1,MG                                                         GHGCR.33    
      II=II+1                                                              GHGCR.34    
      IKK=IKK+1                                                            GHGCR.35    
   20 GHG(II)=GHG(II)+GG*TG(IKK)                                           GHGCR.36    
C                                                                          GHGCR.37    
C     Optionally add orography.                                            GHGCR.38    
C                                                                          GHGCR.39    
      IF (LROG) THEN                                                       GHGCR.40    
         DO 30 IHEM=1,NHEM                                                 GHGCR.41    
         IOF=(IHEM-1)*MGPP                                                 GHGCR.42    
         DO 30 L=1,NL                                                      GHGCR.43    
         K=(L-1)*IGC+IOF                                                   GHGCR.44    
         DO 30 I=1,MG                                                      GHGCR.45    
         K=K+1                                                             GHGCR.46    
   30    GHG(K)=GHG(K)+GSG(I+IOF,JL)                                       GHGCR.47    
      ENDIF                                                                GHGCR.48    
C                                                                          GHGCR.49    
      RETURN                                                               GHGCR.50    
      END                                                                  GHGCR.51    
C     ****************************************************************     GHGCR.52    
*DECK OMGCR                                                                OMGCR.1     
      SUBROUTINE OMGCR                                                     OMGCR.2     
C                                                                          OMGCR.3     
C     Calculate omega on full model levels.                                OMGCR.4     
C     Reading model - sigma.                                               OMGCR.5     
C                                                                          OMGCR.6     
*CALL PARAM1                                                               OMGCR.7     
*CALL PARAM2                                                               OMGCR.8     
*CALL BLANK                                                                OMGCR.9     
*CALL COMPRL                                                               OMGCR.10    
*CALL GRIDP                                                                OMGCR.11    
*CALL LEGAU                                                                OMGCR.12    
      REAL VGPG(NL),TPTB(NL)                                               OMGCR.13    
C                                                                          OMGCR.14    
C     Zero preset.                                                         OMGCR.15    
C                                                                          OMGCR.16    
      DO 10 I=1,IGD                                                        OMGCR.17    
   10 OMG(I)=0.                                                            OMGCR.18    
C                                                                          OMGCR.19    
C     Integrate continuity equation in sigma co-ordinates.                 OMGCR.20    
C                                                                          OMGCR.21    
      DO 100 IHEM=1,NHEM                                                   OMGCR.22    
      IOF=(IHEM-1)*MGPP                                                    OMGCR.23    
      DO 90 I=1,MG                                                         OMGCR.24    
      DO 20 L=1,NL                                                         OMGCR.25    
   20 TPTB(L)=0.0                                                          OMGCR.26    
      II=I+IOF                                                             OMGCR.27    
      K=II                                                                 OMGCR.28    
      LLL=-NL                                                              OMGCR.29    
      DO 40 L=1,NL                                                         OMGCR.30    
      VGP=SECSQ(JH)*(UG(K)*PMG(II)+VG(K)*PJG(II))                          OMGCR.31    
      VGPG(L)=VGP                                                          OMGCR.32    
      LLL=LLL+NLP                                                          OMGCR.33    
      LL=LLL                                                               OMGCR.34    
      DO 30 J=L,NL                                                         OMGCR.35    
      TPTB(J)=TPTB(J)+C(LL)*(VGP+DG(K))                                    OMGCR.36    
   30 LL=LL+NL                                                             OMGCR.37    
   40 K=K+IGC                                                              OMGCR.38    
      K=II                                                                 OMGCR.39    
      DO 50 L=1,NL                                                         OMGCR.40    
      OMG(K)=PSG(II,L)*(VGPG(L)-TPTB(L))                                   OMGCR.41    
   50 K=K+IGC                                                              OMGCR.42    
   90 CONTINUE                                                             OMGCR.43    
  100 CONTINUE                                                             OMGCR.44    
C                                                                          OMGCR.45    
      RETURN                                                               OMGCR.46    
      END                                                                  OMGCR.47    
C     ****************************************************************     OMGCR.48    
*DECK SRFCR                                                                SRFCR.1     
      SUBROUTINE SRFCR                                                     SRFCR.2     
C                                                                          SRFCR.3     
C     Calculate various surface and low level fields for extrapolation     SRFCR.4     
C     below lowest model level (based on constant lapse rate). Also        SRFCR.5     
C     calculate msl pressure.                                              SRFCR.6     
C     Reading model - sigma.                                               SRFCR.7     
C                                                                          SRFCR.8     
*CALL PARAM1                                                               SRFCR.9     
*CALL PARAM2                                                               SRFCR.10    
*CALL BLANK                                                                SRFCR.11    
*CALL COMGRM                                                               SRFCR.12    
*CALL COMPRL                                                               SRFCR.13    
*CALL COMROG                                                               SRFCR.14    
*CALL GRIDP                                                                SRFCR.15    
*CALL LEGAU                                                                SRFCR.16    
C                                                                          SRFCR.17    
C     Default settings for no orography.  Surface temperature extrap       SRFCR.18    
C     from lowest model level using XLAPSE constant lapse rate.            SRFCR.19    
C     Surface pressure copied from PLG (INTER cannot call /GRIDP/).        SRFCR.20    
C     MSL pressure just a copy of surface value.                           SRFCR.21    
C                                                                          SRFCR.22    
      SIGFAC=SIGMA(NL)**(-XLAPSE)                                          SRFCR.23    
      LOF=NLM*IGC                                                          SRFCR.24    
      DO 10 II=1,IGC                                                       SRFCR.25    
      TSRF(II)=TG(LOF+II)*SIGFAC                                           SRFCR.26    
      PSRF(II)=PLG(II)                                                     SRFCR.27    
      PMSLG(II)=PLG(II)                                                    SRFCR.28    
   10 CONTINUE                                                             SRFCR.29    
C                                                                          SRFCR.30    
C     Surface omega from integral of continuity eqaution.                  SRFCR.31    
C                                                                          SRFCR.32    
      DO 20 II=1,IGC                                                       SRFCR.33    
   20 OMSRF(II)=0.                                                         SRFCR.34    
      DO 30 L=1,NL                                                         SRFCR.35    
      IOF=(L-1)*IGC                                                        SRFCR.36    
      DO 30 II=1,IGC                                                       SRFCR.37    
      K=IOF+II                                                             SRFCR.38    
      VGP=SECSQ(JH)*(UG(K)*PMG(II)+VG(K)*PJG(II))                          SRFCR.39    
   30 OMSRF(II)=OMSRF(II)-(VGP+DG(K))*DSIGMA(L)                            SRFCR.40    
      DO 40 II=1,IGC                                                       SRFCR.41    
   40 OMSRF(II)=OMSRF(II)*PLG(II)                                          SRFCR.42    
C                                                                          SRFCR.43    
C     Extrapolation to msl if orography present.                           SRFCR.44    
C                                                                          SRFCR.45    
      IF (LROG) THEN                                                       SRFCR.46    
         RXLAPS=1./XLAPSE                                                  SRFCR.47    
         DO 50 IHEM=1,NHEM                                                 SRFCR.48    
         IOF=(IHEM-1)*MGPP                                                 SRFCR.49    
         DO 50 I=1,MG                                                      SRFCR.50    
         II=I+IOF                                                          SRFCR.51    
         PMSLG(II)=PLG(II)*((1.+XLAPSE*GSG(II,JL)/TSRF(II))**RXLAPS)       SRFCR.52    
   50    CONTINUE                                                          SRFCR.53    
      ENDIF                                                                SRFCR.54    
C                                                                          SRFCR.55    
      RETURN                                                               SRFCR.56    
      END                                                                  SRFCR.57    
C     ****************************************************************     SRFCR.58    
*DECK DLSGCR                                                               DLSGCR.1     
      SUBROUTINE DLSGCR(NCOL,F,RGG,DF,IDIM,NL)                             DLSGCR.2     
C                                                                          DLSGCR.3     
C     Black-box routine to take vertical derivative of a 2D array          DLSGCR.4     
C     in the model's vertical co-ordinates using the RGG matrix:           DLSGCR.5     
C                                                                          DLSGCR.6     
C              DF   =   RGG   *   F                                        DLSGCR.7     
C                                                                          DLSGCR.8     
C     gives    DF   =   d(F)/dln(sigma)   =   (sigma)d(F)/d(sigma).        DLSGCR.9     
C                                                                          DLSGCR.10    
C     Calculates DF at NL levels for NCOL columns from the array F.        DLSGCR.11    
C     Uses vector loops over NCOL at each level.  Note that for            DLSGCR.12    
C     NCOL <= 3 inner loops unroll to give vectorisation over levels.      DLSGCR.13    
C                                                                          DLSGCR.14    
C     Uses explicit values of RGG matrix rather than function SDOT         DLSGCR.15    
C     over NL elements of RGG at each level.  Due to sparse nature         DLSGCR.16    
C     of RGG, this gives large speed-up for NL >> 3.                       DLSGCR.17    
C                                                                          DLSGCR.18    
C     Reading model - sigma.                                               DLSGCR.19    
C                                                                          DLSGCR.20    
      REAL F(IDIM,NL),DF(IDIM,NL),RGG(NL,NL)                               DLSGCR.21    
C                                                                          DLSGCR.22    
 6900 FORMAT(/' ***ABORT IN DLSGCR: MORE COLUMNS THAN ARRAY DIMENSION:'    DLSGCR.23    
     :       ,' NCOL IDIM ='2I10)                                          DLSGCR.24    
C                                                                          DLSGCR.25    
      IF (NCOL.GT.IDIM) THEN                                               DLSGCR.26    
         WRITE(6,6900) NCOL,IDIM                                           DLSGCR.27    
         CALL ABORT                                                        DLSGCR.28    
      ENDIF                                                                DLSGCR.29    
C                                                                          DLSGCR.30    
      NLM=NL-1                                                             DLSGCR.31    
      NLMM=NL-2                                                            DLSGCR.32    
C     Top and bottom levels.                                               DLSGCR.33    
      DO 10 I=1,NCOL                                                       DLSGCR.34    
      DF(I,1 )=F(I,1)*RGG(1,1)+F(I,2)*RGG(2,1)+F(I,3)*RGG(3,1)             DLSGCR.35    
      DF(I,NL)=F(I,NLMM)*RGG(NLMM,NL)+F(I,NLM)*RGG(NLM,NL)                 DLSGCR.36    
     :        +F(I,NL)*RGG(NL,NL)                                          DLSGCR.37    
   10 CONTINUE                                                             DLSGCR.38    
C     Intermediate levels.                                                 DLSGCR.39    
      DO 20 L=2,NLM                                                        DLSGCR.40    
      DO 20 I=1,NCOL                                                       DLSGCR.41    
      DF(I,L)=F(I,L-1)*RGG(L-1,L)+F(I,L+1)*RGG(L+1,L)                      DLSGCR.42    
   20 CONTINUE                                                             DLSGCR.43    
C                                                                          DLSGCR.44    
      RETURN                                                               DLSGCR.45    
      END                                                                  DLSGCR.46    
C     ****************************************************************     DLSGCR.47    
*DECK PVCR                                                                 PVCR.1     
      SUBROUTINE PVCR                                                      PVCR.2     
C                                                                          PVCR.3     
C     Calculate potential temperature and Ertel potential vorticity        PVCR.4     
C     on model levels.                                                     PVCR.5     
C     Interpolate PV, pressure and winds to isentropic levels.             PVCR.6     
C     Reading model - sigma.                                               PVCR.7     
C                                                                          PVCR.8     
*CALL PARAM1                                                               PVCR.9     
*CALL PARAM2                                                               PVCR.10    
*CALL BLANK                                                                PVCR.11    
*CALL COMGRM                                                               PVCR.12    
*CALL COMPRL                                                               PVCR.13    
*CALL GRIDP                                                                PVCR.14    
*CALL LEGAU                                                                PVCR.15    
*CALL OUTCON                                                               PVCR.16    
      DO 100 IHEM=1,NHEM                                                   PVCR.17    
      IOF=(IHEM-1)*MGPP                                                    PVCR.18    
C                                                                          PVCR.19    
C     Calculate potential temperature and PV on model levels.              PVCR.20    
C     Generalised formula using array of model level pressures is used     PVCR.21    
C     to calculate potential temperature.  But note that the reference     PVCR.22    
C     pressure for adiabatic processes is assumed to be P0, the non-       PVCR.23    
C     dimensionalising pressure.                                           PVCR.24    
C                                                                          PVCR.25    
      DO 10 L=1,NL                                                         PVCR.26    
      K=(L-1)*IGC+IOF                                                      PVCR.27    
      DO 10 I=1,MG                                                         PVCR.28    
      II=I+IOF                                                             PVCR.29    
      K=K+1                                                                PVCR.30    
      PMKG=PSG(II,L)**(-AKAP)                                              PVCR.31    
      PM1KG=PMKG/PSG(II,L)                                                 PVCR.32    
      AKT=AKAP*TG(K)                                                       PVCR.33    
      TXP=TXG(K)-AKT*PMG(II)                                               PVCR.34    
      TYP=TYG(K)-AKT*PJG(II)                                               PVCR.35    
      THG(K)=TG(K)*PMKG                                                    PVCR.36    
      EPVG(K)=PM1KG*(ZG(K)*(-DTDLSG(II,L)+AKT)                             PVCR.37    
     :                 +SECSQ(JH)*(-DUDLSG(II,L)*TYP+DVDLSG(II,L)*TXP))    PVCR.38    
   10 CONTINUE                                                             PVCR.39    
C                                                                          PVCR.40    
C     Interpolate to theta surfaces. First set up array containing         PVCR.41    
C     model level directly above required theta level.                     PVCR.42    
C     NB.  ON=J in CFT will give bounds errors in 20 loop (LMIN>NL).       PVCR.43    
C                                                                          PVCR.44    
      DO 40 I=1,MG                                                         PVCR.45    
      II=I+IOF                                                             PVCR.46    
      LM=1                                                                 PVCR.47    
      DO 40 NSF=1,NTHSF                                                    PVCR.48    
      LMIN=LM+1                                                            PVCR.49    
      DO 20 L=LMIN,NLM                                                     PVCR.50    
      K=(L-1)*IGC+II                                                       PVCR.51    
      IF (THSURF(NSF).GT.THG(K)) GOTO 30                                   PVCR.52    
   20 LM=LM+1                                                              PVCR.53    
   30 INTRL(II,NSF)=LM                                                     PVCR.54    
   40 CONTINUE                                                             PVCR.55    
C                                                                          PVCR.56    
C     Set up factor and interpolate linearly in theta.                     PVCR.57    
C                                                                          PVCR.58    
      DO 50 NSF=1,NTHSF                                                    PVCR.59    
      N=(NSF-1)*IGC+IOF                                                    PVCR.60    
      DO 50 I=1,MG                                                         PVCR.61    
      II=I+IOF                                                             PVCR.62    
      N=N+1                                                                PVCR.63    
      LM=INTRL(II,NSF)                                                     PVCR.64    
      KM=(LM-1)*IGC+II                                                     PVCR.65    
      KP=KM+IGC                                                            PVCR.66    
      FACT=(THSURF(NSF)-THG(KM))/(THG(KP)-THG(KM))                         PVCR.67    
      UTHG(N)=UG(KM)+FACT*(UG(KP)-UG(KM))                                  PVCR.68    
      VTHG(N)=VG(KM)+FACT*(VG(KP)-VG(KM))                                  PVCR.69    
      ERTHG(N)=EPVG(KM)+FACT*(EPVG(KP)-EPVG(KM))                           PVCR.70    
      PTHG(N)=PSG(II,LM)+FACT*(PSG(II,LM+1)-PSG(II,LM))                    PVCR.71    
   50 CONTINUE                                                             PVCR.72    
C                                                                          PVCR.73    
C     Finally flag points below lowest model level with values             PVCR.74    
C     suitable for plotting.                                               PVCR.75    
C                                                                          PVCR.76    
      LOF=NLM*IGC                                                          PVCR.77    
      DO 60 NSF=1,NTHSF                                                    PVCR.78    
      K=(NSF-1)*IGC+IOF                                                    PVCR.79    
      DO 60 I=1,MG                                                         PVCR.80    
      II=I+IOF                                                             PVCR.81    
      K=K+1                                                                PVCR.82    
      IF (THSURF(NSF).LT.THG(LOF+II)) THEN                                 PVCR.83    
         UTHG(K)=1.                                                        PVCR.84    
         VTHG(K)=0.                                                        PVCR.85    
         ERTHG(K)=0.                                                       PVCR.86    
         PTHG(K)=1.2                                                       PVCR.87    
      ENDIF                                                                PVCR.88    
   60 CONTINUE                                                             PVCR.89    
C                                                                          PVCR.90    
  100 CONTINUE                                                             PVCR.91    
C                                                                          PVCR.92    
      RETURN                                                               PVCR.93    
      END                                                                  PVCR.94    
C     ****************************************************************     PVCR.95    
*DECK DVPCOR                                                               DVPCOR.1     
      SUBROUTINE DVPCOR                                                    DVPCOR.2     
C                                                                          DVPCOR.3     
C     If interpolating grid point fields from model to isobaric levels,    DVPCOR.4     
C     correct model level vorticity and divergence to those using          DVPCOR.5     
C     gradient operator on pressure surfaces, but leaving fields on        DVPCOR.6     
C     model levels.                                                        DVPCOR.7     
C     Reading model - sigma.                                               DVPCOR.8     
C                                                                          DVPCOR.9     
*CALL PARAM1                                                               DVPCOR.10    
*CALL PARAM2                                                               DVPCOR.11    
*CALL COMGRM                                                               DVPCOR.12    
*CALL GRIDP                                                                DVPCOR.13    
*CALL LEGAU                                                                DVPCOR.14    
      DO 10 IHEM=1,NHEM                                                    DVPCOR.15    
      IOF=(IHEM-1)*MGPP                                                    DVPCOR.16    
      DO 10 L=1,NL                                                         DVPCOR.17    
      K=(L-1)*IGC+IOF                                                      DVPCOR.18    
      DO 10 I=1,MG                                                         DVPCOR.19    
      II=I+IOF                                                             DVPCOR.20    
      K=K+1                                                                DVPCOR.21    
      ZG(K)=ZG(K)-SECSQ(JH)*(DVDLSG(II,L)*PMG(II)-DUDLSG(II,L)*PJG(II))    DVPCOR.22    
      DG(K)=DG(K)-SECSQ(JH)*(DUDLSG(II,L)*PMG(II)+DVDLSG(II,L)*PJG(II))    DVPCOR.23    
   10 CONTINUE                                                             DVPCOR.24    
C                                                                          DVPCOR.25    
      RETURN                                                               DVPCOR.26    
      END                                                                  DVPCOR.27    
C     ****************************************************************     DVPCOR.28    
*DECK INTPR                                                                INTPR.1     
      SUBROUTINE INTPR                                                     INTPR.2     
C                                                                          INTPR.3     
C     Interpolate from model levels to isobaric levels.                    INTPR.4     
C     Can be called from either GRMULT or FLUX, depending on switches      INTPR.5     
C     LINTP2, LINTP3 in common COMPRL.                                     INTPR.6     
C     Extra fields are interpolated when called from GRMULT.               INTPR.7     
C     Reading model - sigma.                                               INTPR.8     
C     NB.  Arrays DUDLSG, DVDLSG in common COMGRM are used as workspace.   INTPR.9     
C                                                                          INTPR.10    
*CALL PARAM1                                                               INTPR.11    
*CALL PARAM2                                                               INTPR.12    
*CALL COMGRM                                                               INTPR.13    
*CALL COMPRL                                                               INTPR.14    
*CALL GRIDP                                                                INTPR.15    
      REAL FINTR(IGC,NL),WKINT(IGC,NL)                                     INTPR.16    
      EQUIVALENCE (FINTR(1,1),DUDLSG(1,1)),(WKINT(1,1),DVDLSG(1,1))        INTPR.17    
C                                                                          INTPR.18    
      DO 100 IHEM=1,NHEM                                                   INTPR.19    
      IOF=(IHEM-1)*MGPP                                                    INTPR.20    
C                                                                          INTPR.21    
C     First set up array INTRL containing model level directly above       INTPR.22    
C     required pressure level.                                             INTPR.23    
C                                                                          INTPR.24    
      DO 30 I=1,MG                                                         INTPR.25    
      II=I+IOF                                                             INTPR.26    
      LM=1                                                                 INTPR.27    
      DO 30 N=1,NLPR                                                       INTPR.28    
      LMIN=LM+1                                                            INTPR.29    
      DO 10 L=LMIN,NLM                                                     INTPR.30    
      IF (PPR(N).LE.PSG(II,L)) GOTO 20                                     INTPR.31    
   10 LM=LM+1                                                              INTPR.32    
   20 INTRL(II,N)=LM                                                       INTPR.33    
   30 CONTINUE                                                             INTPR.34    
C                                                                          INTPR.35    
C     Set up interpolation factors in array FINTR for linear               INTPR.36    
C     interpolation in ln(p).                                              INTPR.37    
C                                                                          INTPR.38    
      DO 40 N=1,NLPR                                                       INTPR.39    
      DO 40 I=1,MG                                                         INTPR.40    
      II=I+IOF                                                             INTPR.41    
      LM=INTRL(II,N)                                                       INTPR.42    
      LP=LM+1                                                              INTPR.43    
   40 FINTR(II,N)=LOG(PPR(N)/PSG(II,LM))/LOG(PSG(II,LP)/PSG(II,LM))        SUNMOD.91    
C                                                                          INTPR.45    
  100 CONTINUE                                                             INTPR.46    
C                                                                          INTPR.47    
C     Finally interpolate and extrapolate fields.                          INTPR.48    
C     Extra fields required if called from GRMULT (LINTP2=.TRUE.).         SUNMOD.57    
C     Final two arguments are switches for upward and downward extrap      INTPR.50    
C     respectively.  See INTER for details.                                INTPR.51    
C                                                                          INTPR.52    
      IF (LINTP2) THEN                                                     INTPR.53    
         CALL INTER(ZG ,WKINT,NLPR,INTRL,FINTR,1,1,0)                      INTPR.54    
         CALL INTER(DG ,WKINT,NLPR,INTRL,FINTR,1,0,0)                      INTPR.55    
         CALL INTER(GHG,WKINT,NLPR,INTRL,FINTR,1,1,4)                      INTPR.56    
      ENDIF                                                                INTPR.57    
      CALL INTER(OMG,WKINT,NLPR,INTRL,FINTR,1,2,2)                         INTPR.58    
      CALL INTER(UG ,WKINT,NLPR,INTRL,FINTR,1,1,0)                         INTPR.59    
      CALL INTER(VG ,WKINT,NLPR,INTRL,FINTR,1,1,0)                         INTPR.60    
      CALL INTER(TG ,WKINT,NLPR,INTRL,FINTR,1,0,3)                         INTPR.61    
      CALL INTER(QG ,WKINT,NLPR,INTRL,FINTR,1,0,0)                         INTPR.62    
      CALL INTER(HG ,WKINT,NLPR,INTRL,FINTR,1,0,5)                         INTPR.63    
      CALL INTER(FUG,WKINT,NLPR,INTRL,FINTR,1,0,5)                         INTPR.64    
      CALL INTER(FVG,WKINT,NLPR,INTRL,FINTR,1,0,5)                         INTPR.65    
C                                                                          INTPR.66    
      RETURN                                                               INTPR.67    
      END                                                                  INTPR.68    
C     ****************************************************************     INTPR.69    
*DECK INTER                                                                INTER.1     
      SUBROUTINE INTER(GIN,GOUT,NLOUT,INTRL,FINTR,JOW,JXUP,JXDN)           INTER.2     
C                                                                          INTER.3     
C     Interpolate vertically from input array GIN(..,NL) to output         INTER.4     
C     array GOUT(..,NLOUT), using pre-determined factors FINTR and         INTER.5     
C     levels INTRL(..,L) and INTRL(..,L+1) in input data for level         INTER.6     
C     L in output data.                                                    INTER.7     
C     If JOW=1, interpolated data is overwritten on first NLOUT levels     INTER.8     
C     of input array.                                                      INTER.9     
C     Extrapolation beyond extreme model levels controlled by namelist     INTER.10    
C     logicals LXTRP2 and LXTRP3 for LPC2 and LPC3 fields respectively.    INTER.11    
C     If switched on, JXUP and JXDN define options used.  If switched      INTER.12    
C     off, input options are overridden and values held constant beyond    INTER.13    
C     extreme model levels (equivalent to JXUP=JXDN=0).                    INTER.14    
C     Current extrapolation options are:                                   INTER.15    
C        Upward  : JXUP = 0  :  constant value above PSG(,1)               INTER.16    
C                         1  :  same as interp - linear in ln(p)           INTER.17    
C                         2  :  linear interp in p, to zero at p=0         INTER.18    
C        Downward: JXDN = 0  :  constant value below PSG(,NL)              INTER.19    
C                         1  :  same as interp - linear in ln(p)           INTER.20    
C                         2  :  interp to surface omega, const below       INTER.21    
C                         3  :  temperature: const lapse below PSG(,NL)    INTER.22    
C                         4  :  Geopotential: based on constant lapse      INTER.23    
C                         5  :  constant down to surface, zero below       INTER.24    
C     NB.  Common COMGRM must not be called as it contains INTRL.          INTER.25    
C     NB.  Common  GRIDP must not be called as it can contain GIN.         INTER.26    
C                                                                          INTER.27    
*CALL PARAM1                                                               INTER.28    
*CALL PARAM2                                                               INTER.29    
*CALL COMPRL                                                               INTER.30    
*CALL COMROG                                                               INTER.31    
*CALL LEGAU                                                                INTER.32    
      INTEGER INTRL(IGC,NLOUT)                                             INTER.33    
      REAL GIN(IGC,NL),GOUT(IGC,NLOUT),FINTR(IGC,NLOUT)                    INTER.34    
      LOGICAL LX                                                           INTER.35    
C                                                                          INTER.36    
 6900 FORMAT(/' ***ABORT IN INTER: IXUP = ,'I3,' NOT ALLOWED')             INTER.37    
 6910 FORMAT(/' ***ABORT IN INTER: IXDN = ,'I3,' NOT ALLOWED')             INTER.38    
C                                                                          INTER.39    
C     Set extrapolation switches.  Override input options if no extrap.    INTER.40    
C                                                                          INTER.41    
      LX=(LINTP2.AND.LXTRP2).OR.(LINTP3.AND.LXTRP3)                        INTER.42    
      IXUP=JXUP                                                            INTER.43    
      IXDN=JXDN                                                            INTER.44    
      IF (.NOT.LX) THEN                                                    INTER.45    
         IXUP=0                                                            INTER.46    
         IXDN=0                                                            INTER.47    
      ENDIF                                                                INTER.48    
C                                                                          INTER.49    
      IF (LX.AND.(IXUP.LT.0.OR.IXUP.GT.2)) THEN                            INTER.50    
         WRITE(6,6900) IXUP                                                INTER.51    
         CALL ABORT                                                        INTER.52    
      ENDIF                                                                INTER.53    
      IF (LX.AND.(IXDN.LT.0.OR.IXDN.GT.5)) THEN                            INTER.54    
         WRITE(6,6910) IXDN                                                INTER.55    
         CALL ABORT                                                        INTER.56    
      ENDIF                                                                INTER.57    
C                                                                          INTER.58    
      DO 300 IHEM=1,NHEM                                                   INTER.59    
      IOF=(IHEM-1)*MGPP                                                    INTER.60    
C                                                                          INTER.61    
C     First perform interpolation and implied extrapolation using          INTER.62    
C     default factors.                                                     INTER.63    
C                                                                          INTER.64    
      DO 5 N=1,NLOUT                                                       INTER.65    
      DO 5 I=1,MG                                                          INTER.66    
      II=I+IOF                                                             INTER.67    
      LM=INTRL(II,N)                                                       INTER.68    
    5 GOUT(II,N)=GIN(II,LM)+FINTR(II,N)*(GIN(II,LM+1)-GIN(II,LM))          INTER.69    
C                                                                          INTER.70    
C     Upward extrapolation.  Skip levels for which pressure level is       INTER.71    
C     wholly below top model level.                                        INTER.72    
C                                                                          INTER.73    
      IF (IXUP.EQ.1) GOTO 100                                              INTER.74    
      DO 90 N=1,NLOUT                                                      INTER.75    
      IF (PPR(N).GE.PSGMX(1,IHEM)) GOTO 90                                 INTER.76    
      IF (IXUP.EQ.0) THEN                                                  INTER.77    
         DO 10 I=1,MG                                                      INTER.78    
         II=I+IOF                                                          INTER.79    
         IF (PPR(N).LT.PSG(II,1)) GOUT(II,N)=GIN(II,1)                     INTER.80    
   10    CONTINUE                                                          INTER.81    
      ELSE IF (IXUP.EQ.2) THEN                                             INTER.82    
         DO 20 I=1,MG                                                      INTER.83    
         II=I+IOF                                                          INTER.84    
         IF (PPR(N).LT.PSG(II,1))  GOUT(II,N)=GIN(II,1)*PPR(N)/PSG(II,1)   INTER.85    
   20    CONTINUE                                                          INTER.86    
      ENDIF                                                                INTER.87    
   90 CONTINUE                                                             INTER.88    
C                                                                          INTER.89    
C     Downward extrapolation.  Skip levels for which pressure level is     INTER.90    
C     wholly above bottom model level.                                     INTER.91    
C                                                                          INTER.92    
  100 CONTINUE                                                             INTER.93    
      IF (IXDN.EQ.1) GOTO 200                                              INTER.94    
      DO 190 N=1,NLOUT                                                     INTER.95    
      IF (PPR(N).LE.PSGMN(NL,IHEM)) GOTO 190                               INTER.96    
      IF (IXDN.EQ.0) THEN                                                  INTER.97    
         DO 110 I=1,MG                                                     INTER.98    
         II=I+IOF                                                          INTER.99    
         IF (PPR(N).GT.PSG(II,NL)) GOUT(II,N)=GIN(II,NL)                   INTER.100   
  110    CONTINUE                                                          INTER.101   
      ELSE IF (IXDN.EQ.2) THEN                                             INTER.102   
         DO 120 I=1,MG                                                     INTER.103   
         II=I+IOF                                                          INTER.104   
         IF (PPR(N).GT.PSRF(II)) GOUT(II,N)=OMSRF(II)                      INTER.105   
         IF (PPR(N).GT.PSG(II,NL).AND.PPR(N).LE.PSRF(II))                  INTER.106   
     :      GOUT(II,N)=GIN(II,NL)+(OMSRF(II)-GIN(II,NL))*                  INTER.107   
     :                 (PPR(N)-PSG(II,NL))/(PSRF(II)-PSG(II,NL))           INTER.108   
  120    CONTINUE                                                          INTER.109   
      ELSE IF (IXDN.EQ.3) THEN                                             INTER.110   
         DO 130 I=1,MG                                                     INTER.111   
         II=I+IOF                                                          INTER.112   
         IF (PPR(N).GT.PSG(II,NL))                                         INTER.113   
     :      GOUT(II,N)=GIN(II,NL)*((PPR(N)/PSG(II,NL))**XLAPSE)            INTER.114   
  130    CONTINUE                                                          INTER.115   
      ELSE IF (IXDN.EQ.4) THEN                                             INTER.116   
         DO 140 I=1,MG                                                     INTER.117   
         II=I+IOF                                                          INTER.118   
         IF (PPR(N).GT.PSRF(II))                                           INTER.119   
     :      GOUT(II,N)=GSG(II,JL)-(TSRF(II)/XLAPSE)*                       INTER.120   
     :                            ((PPR(N)/PSRF(II))**XLAPSE-1.)           INTER.121   
         IF (PPR(N).GT.PSG(II,NL).AND.PPR(N).LE.PSRF(II))                  INTER.122   
     :      GOUT(II,N)=GIN(II,NL)+(GSG(II,JL)-GIN(II,NL))*                 INTER.123   
     :               LOG(PPR(N)/PSG(II,NL))/LOG(PSRF(II)/PSG(II,NL))       SUNMOD.92    
  140    CONTINUE                                                          INTER.125   
      ELSE IF (IXDN.EQ.5) THEN                                             INTER.126   
         DO 150 I=1,MG                                                     INTER.127   
         II=I+IOF                                                          INTER.128   
         IF (PPR(N).GT.PSRF(II)) GOUT(II,N)=0.                             INTER.129   
         IF (PPR(N).GT.PSG(II,NL).AND.PPR(N).LE.PSRF(II))                  INTER.130   
     :      GOUT(II,N)=GIN(II,NL)                                          INTER.131   
  150    CONTINUE                                                          INTER.132   
      ENDIF                                                                INTER.133   
  190 CONTINUE                                                             INTER.134   
C                                                                          INTER.135   
C     Copy to overwrite the input array if requested.                      INTER.136   
C                                                                          INTER.137   
  200 CONTINUE                                                             INTER.138   
      IF (JOW.EQ.1) THEN                                                   INTER.139   
         DO 210 N=1,NLOUT                                                  INTER.140   
         DO 210 I=1,MG                                                     INTER.141   
         II=I+IOF                                                          INTER.142   
  210    GIN(II,N)=GOUT(II,N)                                              INTER.143   
      ENDIF                                                                INTER.144   
C                                                                          INTER.145   
  300 CONTINUE                                                             INTER.146   
C                                                                          INTER.147   
      RETURN                                                               INTER.148   
      END                                                                  INTER.149   
C     ****************************************************************     INTER.150   
*DECK SFGCPR                                                               SFGCPR.1     
      SUBROUTINE SFGCPR                                                    SFGCPR.2     
C                                                                          SFGCPR.3     
C     Obtain grid point streamfunction from grid point vorticity.          SFGCPR.4     
C     Same level type and defn of gradient operator in both fields.        SFGCPR.5     
C     Involves direct spectral transform to spectral vorticity, then       SFGCPR.6     
C     inverse transform using (del)-2 operator for streamfunction.         SFGCPR.7     
C     Used when pressure level fields are required.                        SFGCPR.8     
C     NB.  Overwrites spectral vorticity with pressure-level values.       SFGCPR.9     
C                                                                          SFGCPR.10    
*CALL PARAM1                                                               SFGCPR.11    
*CALL PARAM2                                                               SFGCPR.12    
*CALL BLANK                                                                SFGCPR.13    
*CALL COMFFT                                                               SFGCPR.14    
*CALL COMIOC                                                               SFGCPR.15    
*CALL COMPRL                                                               SFGCPR.16    
*CALL GRIDP                                                                SFGCPR.17    
*CALL LEGAU                                                                SFGCPR.18    
*CALL SPECTR                                                               SFGCPR.19    
C                                                                          SFGCPR.20    
C     Direct transform to obtain spectral from grid point vorticity.       SFGCPR.21    
C     Preset spectral array to zero.                                       SFGCPR.22    
C                                                                          SFGCPR.23    
      DO 10 I=1,IGB                                                        SFGCPR.24    
   10 Z(I)=CMPLX(0.,0.)                                                    SFGCPR.25    
C                                                                          SFGCPR.26    
      JL=1                                                                 SFGCPR.27    
      REWIND NCGP(2)                                                       SFGCPR.28    
      IF (JGL.EQ.1) REWIND NCLEG                                           SFGCPR.29    
      DO 50 IH=1,JG                                                        SFGCPR.30    
      IF (JGL.EQ.1) READ(NCLEG) ALP                                        SFGCPR.31    
      READ(NCGP(2)) ZG                                                     SFGCPR.32    
      IF (NTNL.EQ.0) GOTO 30                                               SFGCPR.33    
      DO 20 I=1,NTNL                                                       SFGCPR.34    
   20 CALL FFT991(ZG(1+(I-1)*NCRAY*MGPP),WORK,TRIG,IFAX                    SFGCPR.35    
     :           ,1,MGPP,MG,NCRAY,-1)                                      SFGCPR.36    
   30 CALL FFT991(ZG(1+NTNL*NCRAY*MGPP),WORK,TRIG,IFAX                     SFGCPR.37    
     :           ,1,MGPP,MG,NRSTNL,-1)                                     SFGCPR.38    
      JH=IH                                                                SFGCPR.39    
      CALL HANAL(ZG,Z,NLPR,1)                                              SFGCPR.40    
   50 JL=JL+JINC                                                           SFGCPR.41    
C                                                                          SFGCPR.42    
C     Indirect transform back to grid point space, performing the          SFGCPR.43    
C     (del)**(-2) operation to obtain streamfunction.                      SFGCPR.44    
C     Vorticity includes planetary component, so temporarily remove.       SFGCPR.45    
C     Set (m=0,n=0) coefficient to zero at all levels.                     SFGCPR.46    
C                                                                          SFGCPR.47    
      DO 60 I=1,IGB,IGA                                                    SFGCPR.48    
   60 Z(I)=Z(I)-EZ                                                         SFGCPR.49    
      IF (NHEM.EQ.2) THEN                                                  SFGCPR.50    
         DO 70 I=NWJ2+1,IGB,IGA                                            SFGCPR.51    
   70    Z(I)=0.                                                           SFGCPR.52    
      ENDIF                                                                SFGCPR.53    
C                                                                          SFGCPR.54    
      JL=1                                                                 SFGCPR.55    
      REWIND NCGP(1)                                                       SFGCPR.56    
      IF (JGL.EQ.1) REWIND NCLEG                                           SFGCPR.57    
      DO 100 IH=1,JG                                                       SFGCPR.58    
      IF (JGL.EQ.1) READ(NCLEG) ALP,DALP,RLP                               SFGCPR.59    
      CALL HEXP(Z,SFG,NLPR,5)                                              SFGCPR.60    
      IF (NTNL.EQ.0) GOTO 90                                               SFGCPR.61    
      DO 80 I=1,NTNL                                                       SFGCPR.62    
   80 CALL FFT991(SFG(1+(I-1)*NCRAY*MGPP),WORK,TRIG,IFAX                   SFGCPR.63    
     :           ,1,MGPP,MG,NCRAY,1)                                       SFGCPR.64    
   90 CALL FFT991(SFG(1+NTNL*NCRAY*MGPP),WORK,TRIG,IFAX                    SFGCPR.65    
     :           ,1,MGPP,MG,NRSTNL,1)                                      SFGCPR.66    
      WRITE(NCGP(1)) SFG                                                   SFGCPR.67    
  100 JL=JL+JINC                                                           SFGCPR.68    
C                                                                          SFGCPR.69    
      DO 110 I=1,IGB,IGA                                                   SFGCPR.70    
  110 Z(I)=Z(I)+EZ                                                         SFGCPR.71    
C                                                                          SFGCPR.72    
      RETURN                                                               SFGCPR.73    
      END                                                                  SFGCPR.74    
C     ****************************************************************     SFGCPR.75    
*DECK FLUX                                                                 FLUX.1     
      SUBROUTINE FLUX                                                      FLUX.2     
C                                                                          FLUX.3     
C     Calculate zonally averaged fields at current analysis time and       FLUX.4     
C     store in common ZONAV.  Increment their time averages in common      FLUX.5     
C     TAV.  Uses full 3-dimensional fields from scratch files.             FLUX.6     
C                                                                          FLUX.7     
C     Averages are taken on isobaric levels, so interpolate from model     FLUX.8     
C     levels if necessary.  It is assumed there are NL isobaric levels     FLUX.9     
C     with p(l) = P0*sigma(l).  Program should have aborted in INIPLV      FLUX.10    
C     or switched off these diagnostics if any other pressure levels       FLUX.11    
C     were requested.                                                      FLUX.12    
C                                                                          FLUX.13    
C     NB.  FLUX can be called using data on model levels,                  SUNMOD.58    
C         (LINTP2=.FALSE., LINTP3=.FALSE.)                                 SUNMOD.59    
c      but then several fields are invalid since their                     SUNMOD.60    
C     calculation assumes isobaric data: potential temperature, relative   FLUX.16    
C     humidity and derived dynamical fields.                               FLUX.17    
C     NB.  Calculations for several fields assume isobaric levels are      FLUX.18    
C     P0*sigma by using the fact that non-dimensional pressure is then     FLUX.19    
C     just sigma.                                                          FLUX.20    
C     NB.  The reference pressure for adiabatic processes is assumed       FLUX.21    
C     to be the non-dimensionalising P0.                                   FLUX.22    
C                                                                          FLUX.23    
C     NB.  Following zonal arrays used as workspace:                       FLUX.24    
C          DUMNZ, DUMCN, DUMCK, DUMBP.                                     FLUX.25    
C                                                                          FLUX.26    
*CALL PARAM1                                                               FLUX.27    
*CALL PARAM2                                                               FLUX.28    
*CALL BATS                                                                 FLUX.29    
*CALL BLANK                                                                FLUX.30    
*CALL COMGEN                                                               FLUX.31    
*CALL COMIOC                                                               FLUX.32    
*CALL COMPRL                                                               FLUX.33    
*CALL COMROG                                                               FLUX.34    
*CALL GRIDP                                                                FLUX.35    
*CALL LEGAU                                                                FLUX.36    
*CALL PHYS                                                                 FLUX.37    
*CALL TAV                                                                  FLUX.38    
*CALL ZONAV                                                                FLUX.39    
      REAL DDZ(IDDZ),DDZT(IDDZ)                                            FLUX.40    
     :    ,FUBR(JGG,NL),FVBR(JGG,NL),TEMPZ(JGG,NL)                         FLUX.41    
     :    ,RHG(IGD),TEMP(NL)                                               FLUX.42    
      EQUIVALENCE (DDZ(1),UBR(1,1)),(DDZT(1),UBT(1,1))                     FLUX.43    
     :           ,(RHG(1),EPVG(1))                                         FLUX.44    
     :           ,(FUBR(1,1),DUMCN(1,1)),(FVBR(1,1),DUMCK(1,1))            FLUX.45    
     :           ,(TEMPZ(1,1),DUMNZ(1,1))                                  FLUX.46    
C                                                                          FLUX.47    
C     Rewind scratch files.                                                FLUX.48    
C                                                                          FLUX.49    
      IF (LROG.AND.JGL.EQ.1) REWIND NCROGG                                 FLUX.50    
      DO 10 I=1,NGP                                                        FLUX.51    
   10 REWIND NCGP(I)                                                       FLUX.52    
C                                                                          FLUX.53    
C     Vertical derivatives of restoration temperatures.                    FLUX.54    
C                                                                          FLUX.55    
      CALL DLSGCR(JGG,TBRES,RGG,DUMBP,JGG,NL)                              FLUX.56    
C                                                                          FLUX.57    
C     ----------------------------------------------------------------     FLUX.58    
C     Main loop over latitude.  First read data.                           FLUX.59    
C                                                                          FLUX.60    
      JL=1                                                                 FLUX.61    
      DO 90 IH=1,JG                                                        FLUX.62    
      JH=IH                                                                FLUX.63    
C                                                                          FLUX.64    
      IF (LROG.AND.JGL.EQ.1) READ(NCROGG) GSG                              FLUX.65    
      READ(NCGP( 3)) DG                                                    FLUX.66    
      READ(NCGP( 4)) OMG                                                   FLUX.67    
      READ(NCGP( 5)) UG                                                    FLUX.68    
      READ(NCGP( 6)) VG                                                    FLUX.69    
      READ(NCGP( 7)) TG                                                    FLUX.70    
      READ(NCGP( 9)) QG                                                    FLUX.71    
      READ(NCGP(10)) HG                                                    FLUX.72    
      READ(NCGP(11)) PLG,PMG,PJG                                           FLUX.73    
      READ(NCGP(13)) FUG                                                   FLUX.74    
      READ(NCGP(14)) FVG                                                   FLUX.75    
      RMGSEC=RMG*SQRT(SECSQ(IH))                                           FLUX.76    
      RMGSSQ=RMG*SECSQ(IH)                                                 FLUX.77    
C                                                                          FLUX.78    
C     Interpolate to isobaric levels if required.                          FLUX.79    
C                                                                          FLUX.80    
      IF (LINTP3.AND.(.NOT.LINTP2)) THEN                                   FLUX.81    
         CALL PSGCR                                                        FLUX.82    
         CALL SRFCR                                                        FLUX.83    
         CALL INTPR                                                        FLUX.84    
      ENDIF                                                                FLUX.85    
C                                                                          FLUX.86    
      DO 80 IHEM=1,NHEM                                                    FLUX.87    
      IOF=(IHEM-1)*MGPP                                                    FLUX.88    
      IK=(3-2*IHEM)*IH+(JGG+1)*(IHEM-1)                                    FLUX.89    
C                                                                          FLUX.90    
C     Calculate potential temperature and relative humidity.               FLUX.91    
C     Use formula from SGCM, PDN=BGCM5,ID=UPLIB,ED=5, for Qs(T,p).         FLUX.92    
C                                                                          FLUX.93    
      DO 20 L=1,NL                                                         FLUX.94    
      K=(L-1)*IGC+IOF                                                      FLUX.95    
      DO 20 I=1,MG                                                         FLUX.96    
      K=K+1                                                                FLUX.97    
      THG(K)=TG(K)*SIGMAK(L)                                               FLUX.98    
      QS=ESCONA*EXP(-ESCONB/TG(K))/SIGMA(L)                                FLUX.99    
      RHG(K)=QG(K)/QS                                                      FLUX.100   
   20 CONTINUE                                                             FLUX.101   
C                                                                          FLUX.102   
C     Form zonal averages of basic fields and variances.                   FLUX.103   
C     Arrays in ZONAV have point nearest north pole stored first           FLUX.104   
C     and, for NHEM=2, point nearest south pole stored last.               FLUX.105   
C                                                                          FLUX.106   
      SFM=0.                                                               FLUX.107   
      DO 30 L=1,NL                                                         FLUX.108   
      I=(L-1)*IGC+IOF+1                                                    FLUX.109   
      UBR(IK,L) =SSUM(MG,UG(I) ,1)*RMGSEC                                  FLUX.110   
      VBR(IK,L) =SSUM(MG,VG(I) ,1)*RMGSEC                                  FLUX.111   
      WBR(IK,L) =SSUM(MG,OMG(I),1)*RMG                                     FLUX.112   
      TBR(IK,L) =SSUM(MG,TG(I) ,1)*RMG                                     FLUX.113   
      QBR(IK,L) =SSUM(MG,QG(I) ,1)*RMG                                     FLUX.114   
      HBR(IK,L) =SSUM(MG,HG(I) ,1)*RMG                                     FLUX.115   
      RHBR(IK,L)=SSUM(MG,RHG(I),1)*RMG                                     FLUX.116   
      THBR(IK,L)=SSUM(MG,THG(I),1)*RMG                                     FLUX.117   
      FUBR(IK,L)=SSUM(MG,FUG(I),1)*RMGSEC                                  FLUX.118   
      FVBR(IK,L)=SSUM(MG,FVG(I),1)*RMGSEC                                  FLUX.119   
      UVBR(IK,L)=SDOT(MG,UG(I),1,VG(I) ,1)*RMGSSQ                          FLUX.120   
      UWBR(IK,L)=SDOT(MG,UG(I),1,OMG(I),1)*RMGSEC                          FLUX.121   
      VTBR(IK,L)=SDOT(MG,VG(I),1,TG(I) ,1)*RMGSEC                          FLUX.122   
      WTBR(IK,L)=SDOT(MG,TG(I),1,OMG(I),1)*RMG                             FLUX.123   
      VQBR(IK,L)=SDOT(MG,VG(I),1,QG(I) ,1)*RMGSEC                          FLUX.124   
      WQBR(IK,L)=SDOT(MG,QG(I),1,OMG(I),1)*RMG                             FLUX.125   
      UUBR(IK,L)=SDOT(MG,UG(I),1,UG(I) ,1)*RMGSSQ                          FLUX.126   
      VVBR(IK,L)=SDOT(MG,VG(I),1,VG(I) ,1)*RMGSSQ                          FLUX.127   
      TTBR(IK,L)=SDOT(MG,TG(I),1,TG(I) ,1)*RMG                             FLUX.128   
      HTBR(IK,L)=SDOT(MG,HG(I),1,TG(I) ,1)*RMG                             FLUX.129   
      VWBR(IK,L)=SDOT(MG,VG(I),1,OMG(I),1)*RMGSEC                          FLUX.130   
      FUER(IK,L)=(SDOT(MG,FUG(I),1,UG(I),1)                                FLUX.131   
     :           +SDOT(MG,FVG(I),1,VG(I),1))*RMGSSQ                        FLUX.132   
      SF=SFM+DSIGMA(L)*VBR(IK,L)*CS(IH)                                    FLUX.133   
      SFMCR(IK,L)=.5*(SF+SFM)                                              FLUX.134   
      SFM=SF                                                               FLUX.135   
   30 CONTINUE                                                             FLUX.136   
C                                                                          FLUX.137   
      BP=SSUM(MG,PLG(IOF+1),1)*RMG-1.                                      FLUX.138   
      DO 40 L=1,NL                                                         FLUX.139   
      TMTRES(IK,L)=TBR(IK,L)-(TBRES(IK,L)-BP*DUMBP(IK,L))                  FLUX.140   
   40 CONTINUE                                                             FLUX.141   
C                                                                          FLUX.142   
   80 CONTINUE                                                             FLUX.143   
C                                                                          FLUX.144   
   90 JL=JL+JINC                                                           FLUX.145   
C                                                                          FLUX.146   
C     ----------------------------------------------------------------     FLUX.147   
C     End of main latitude loop.                                           FLUX.148   
C                                                                          FLUX.149   
C     Calculate layer mean and global mean values of omega,                FLUX.150   
C     temperature and diabatic heating.                                    FLUX.151   
C                                                                          FLUX.152   
      WMNN=GAV(WBR,GWT,JGG,DSIGMA,NL,WMN)                                  FLUX.153   
      TMNN=GAV(TBR,GWT,JGG,DSIGMA,NL,TMN)                                  FLUX.154   
      HMNN=GAV(HBR,GWT,JGG,DSIGMA,NL,HMN)                                  FLUX.155   
C                                                                          FLUX.156   
C     Separate zonal and eddy variances, calculate other derived fields.   FLUX.157   
C     NB.  To prevent contamination of energy conversions, remove          FLUX.158   
C     isobaric means of omega, temperature and heating from mean heat      FLUX.159   
C     flux and heating arrays (VBTBR, WBTBR, HBTBR).                       FLUX.160   
C     NB.  Layer mean omega is theoretically zero on all global isobaric   FLUX.161   
C     surfaces above orography but numerical estimates are generally non   FLUX.162   
C     zero.  It does not enter the global energetics so, in order not to   FLUX.163   
C     contaminate the results, is removed at all levels irrespective of    FLUX.164   
C     whether above or below orography, model-level or isobaric. It is     FLUX.165   
C     NOT removed from the omega array itself.  If this is done, it must   FLUX.166   
C     be AFTER separating the zonal and eddy variances, or the vertical    FLUX.167   
C     eddy fluxes will be contaminated.                                    FLUX.168   
C                                                                          FLUX.169   
      DO 100 L=1,NL                                                        FLUX.170   
      DO 100 J=1,JGG                                                       FLUX.171   
      UVBR(J,L)=UVBR(J,L)-UBR(J,L)*VBR(J,L)                                FLUX.172   
      UWBR(J,L)=UWBR(J,L)-UBR(J,L)*WBR(J,L)                                FLUX.173   
      VTBR(J,L)=VTBR(J,L)-VBR(J,L)*TBR(J,L)                                FLUX.174   
      WTBR(J,L)=WTBR(J,L)-WBR(J,L)*TBR(J,L)                                FLUX.175   
      VQBR(J,L)=VQBR(J,L)-VBR(J,L)*QBR(J,L)                                FLUX.176   
      WQBR(J,L)=WQBR(J,L)-WBR(J,L)*QBR(J,L)                                FLUX.177   
      UUBR(J,L)=UUBR(J,L)-UBR(J,L)*UBR(J,L)                                FLUX.178   
      VVBR(J,L)=VVBR(J,L)-VBR(J,L)*VBR(J,L)                                FLUX.179   
      TTBR(J,L)=TTBR(J,L)-TBR(J,L)*TBR(J,L)                                FLUX.180   
      HTBR(J,L)=HTBR(J,L)-HBR(J,L)*TBR(J,L)                                FLUX.181   
      VWBR(J,L)=VWBR(J,L)-VBR(J,L)*WBR(J,L)                                FLUX.182   
      AKZ (J,L)=.5*(UBR(J,L)*UBR(J,L)+VBR(J,L)*VBR(J,L))                   FLUX.183   
      AKE (J,L)=.5*(UUBR(J,L)+VVBR(J,L))                                   FLUX.184   
      FUZR(J,L)=FUBR(J,L)*UBR(J,L)+FVBR(J,L)*VBR(J,L)                      FLUX.185   
      FUER(J,L)=FUER(J,L)-FUZR(J,L)                                        FLUX.186   
      VBTBR(J,L)=VBR(J,L)*(TBR(J,L)-TMN(L))                                FLUX.187   
      WBTBR(J,L)=(WBR(J,L)-WMN(L))*(TBR(J,L)-TMN(L))                       FLUX.188   
      HBTBR(J,L)=(HBR(J,L)-HMN(L))*(TBR(J,L)-TMN(L))                       FLUX.189   
  100 CONTINUE                                                             FLUX.190   
C                                                                          FLUX.191   
C     Derive remaining zonally averaged quantities.                        FLUX.192   
C                                                                          FLUX.193   
C     Calculate terms involving first meridional derivative.               FLUX.194   
C                                                                          FLUX.195   
      DO 110 L=1,NL                                                        FLUX.196   
      DO 110 J=2,JGGM                                                      FLUX.197   
      JM=J-1                                                               FLUX.198   
      JP=J+1                                                               FLUX.199   
      DM=1./(SI(JP)-SI(JM))                                                FLUX.200   
      ABSV(J,L)=SI(J)+SI(J)-(UBR(JP,L)*CS(JP)-UBR(JM,L)*CS(JM))*DM         FLUX.201   
      DUBDMU(J,L)=(UBR(JP,L)/CS(JP)-UBR(JM,L)/CS(JM))*DM                   FLUX.202   
      DVBDMU(J,L)=(VBR(JP,L)/CS(JP)-VBR(JM,L)/CS(JM))*DM                   FLUX.203   
      DTBDMU(J,L)=(TBR(JP,L)-TBR(JM,L))*DM                                 FLUX.204   
  110 CONTINUE                                                             FLUX.205   
C                                                                          FLUX.206   
C     Extrapolate to northern- and southernmost Gaussian latitudes.        FLUX.207   
C                                                                          FLUX.208   
      DO 120 L=1,NL                                                        FLUX.209   
      ABSV(  1,L)  =EXN1*ABSV(   2,L)  -EXN2*ABSV(    3,L)                 FLUX.210   
      ABSV(JGG,L)  =EXS1*ABSV(JGGM,L)  -EXS2*ABSV(JGGM2,L)                 FLUX.211   
      DUBDMU(  1,L)=EXN1*DUBDMU(   2,L)-EXN2*DUBDMU(    3,L)               FLUX.212   
      DUBDMU(JGG,L)=EXS1*DUBDMU(JGGM,L)-EXS2*DUBDMU(JGGM2,L)               FLUX.213   
      DVBDMU(  1,L)=EXN1*DVBDMU(   2,L)-EXN2*DVBDMU(    3,L)               FLUX.214   
      DVBDMU(JGG,L)=EXS1*DVBDMU(JGGM,L)-EXS2*DVBDMU(JGGM2,L)               FLUX.215   
      DTBDMU(  1,L)=EXN1*DTBDMU(   2,L)-EXN2*DTBDMU(    3,L)               FLUX.216   
      DTBDMU(JGG,L)=EXS1*DTBDMU(JGGM,L)-EXS2*DTBDMU(JGGM2,L)               FLUX.217   
  120 CONTINUE                                                             FLUX.218   
C                                                                          FLUX.219   
C     Calculate terms involving first vertical derivative.                 FLUX.220   
C                                                                          FLUX.221   
      CALL DLSGCR(JGG,UBR,RGG,UBRP,JGG,NL)                                 FLUX.222   
      CALL DLSGCR(JGG,VBR,RGG,VBRP,JGG,NL)                                 FLUX.223   
      CALL DLSGCR(JGG,TBR,RGG,STBP,JGG,NL)                                 FLUX.224   
      AG=1.                                                                FLUX.225   
      DO 130 L=1,NL                                                        FLUX.226   
      DO 130 J=1,JGG                                                       FLUX.227   
      UBRP(J,L)=UBRP(J,L)/SIGMA(L)                                         FLUX.228   
      VBRP(J,L)=VBRP(J,L)/SIGMA(L)                                         FLUX.229   
      THBP(J,L)=(STBP(J,L)-AKAP*TBR(J,L))/SIGMA(L)                         FLUX.230   
      ENSQ(J,L)=-THBP(J,L)*SIGMA(L)/(TBR(J,L)*TBR(J,L))                    FLUX.231   
      TEMPZ(J,L)=UBRP(J,L)*SIGMA(L)/THBP(J,L)                              FLUX.232   
      EPFH(J,L)=CSSQ(J)*(-UVBR(J,L)+AG*UBRP(J,L)*VTBR(J,L)/THBP(J,L))      FLUX.233   
      EPFV(J,L)=CSSQ(J)*(AG*UWBR(J,L)-ABSV(J,L)*VTBR(J,L)/THBP(J,L))       FLUX.234   
  130 CONTINUE                                                             FLUX.235   
C                                                                          FLUX.236   
C     Calculate terms involving second meridional derivative.              FLUX.237   
C                                                                          FLUX.238   
      DO 140 L=1,NL                                                        FLUX.239   
      DO 140 J=2,JGGM                                                      FLUX.240   
      JM=J-1                                                               FLUX.241   
      JP=J+1                                                               FLUX.242   
      DM=1.0/(SI(JP)-SI(JM))                                               FLUX.243   
      QY(J,L)=(ABSV(JP,L)-ABSV(JM,L))*DM                                   FLUX.244   
      EPDH(J,L)=CS(J)*(EPFH(JP,L)-EPFH(JM,L))*DM                           FLUX.245   
  140 CONTINUE                                                             FLUX.246   
C                                                                          FLUX.247   
C     Extrapolate to northern- and southernmost Gaussian latitudes.        FLUX.248   
C                                                                          FLUX.249   
      DO 150 L=1,NL                                                        FLUX.250   
      QY(  1,L)  =EXN1*QY(   2,L)  -EXN2*QY(    3,L)                       FLUX.251   
      QY(JGG,L)  =EXS1*QY(JGGM,L)  -EXS2*QY(JGGM2,L)                       FLUX.252   
      EPDH(  1,L)=EXN1*EPDH(   2,L)-EXN2*EPDH(    3,L)                     FLUX.253   
      EPDH(JGG,L)=EXS1*EPDH(JGGM,L)-EXS2*EPDH(JGGM2,L)                     FLUX.254   
  150 CONTINUE                                                             FLUX.255   
C                                                                          FLUX.256   
C     Calculate terms involving second vertical derivatives.               FLUX.257   
C     Form total E-P flux divergence.                                      FLUX.258   
C                                                                          FLUX.259   
      CALL DLSGCR(JGG,TEMPZ,RGG,DUMBP,JGG,NL)                              FLUX.260   
      CALL DLSGCR(JGG,EPFV,RGG,EPDV,JGG,NL)                                FLUX.261   
      DO 160 L=1,NL                                                        FLUX.262   
      DO 160 J=1,JGG                                                       FLUX.263   
      QY(J,L)=QY(J,L)*CS(J)+DUMBP(J,L)*4.*SISQ(J)/SIGMA(L)                 FLUX.264   
      EPDV(J,L)=-EPDV(J,L)/SIGMA(L)                                        FLUX.265   
      EPDT(J,L)=EPDH(J,L)+EPDV(J,L)                                        FLUX.266   
  160 CONTINUE                                                             FLUX.267   
C                                                                          FLUX.268   
C     Calculate maximum permitted wavenumber for waves with specified      FLUX.269   
C     eastward phase speed.                                                FLUX.270   
C                                                                          FLUX.271   
      DO 170 J=1,JGG                                                       FLUX.272   
      DO 170 L=1,NL                                                        FLUX.273   
      UMC=UBR(J,L)/CS(J)-CPHASE                                            FLUX.274   
      IF (UMC.EQ.0.) THEN                                                  FLUX.275   
         A=1.E4                                                            FLUX.276   
      ELSE                                                                 FLUX.277   
         A=QY(J,L)*CS(J)/UMC                                               FLUX.278   
         IF (A.LT.0.) A=1.E4                                               FLUX.279   
      ENDIF                                                                FLUX.280   
      TPWN(J,L)=SQRT(A)                                                    FLUX.281   
  170 CONTINUE                                                             FLUX.282   
C                                                                          FLUX.283   
C     Set up factor for time-averaging.                                    FLUX.284   
C     Increment time averages of zonally averaged arrays.                  FLUX.285   
C                                                                          FLUX.286   
      IF (LTAV) THEN                                                       FLUX.287   
         FD=FTAV                                                           FLUX.288   
         IF (KOUNT.EQ.KSTART.OR.KOUNT.EQ.KEND) FD=.5*FD                    FLUX.289   
         DO 180 I=1,IDDZ                                                   FLUX.290   
  180    DDZT(I)=DDZT(I)+FD*DDZ(I)                                         FLUX.291   
      ENDIF                                                                FLUX.292   
C                                                                          FLUX.293   
C     Rewind scratch files.                                                FLUX.294   
C                                                                          FLUX.295   
      IF (LROG.AND.JGL.EQ.1) REWIND NCROGG                                 FLUX.296   
      DO 190 I=1,NGP                                                       FLUX.297   
  190 REWIND NCGP(I)                                                       FLUX.298   
C                                                                          FLUX.299   
      RETURN                                                               FLUX.300   
      END                                                                  FLUX.301   
C     ****************************************************************     FLUX.302   
*DECK GAV                                                                  GAV.1     
      FUNCTION GAV(F,GWT,JM,G,LM,TEMP)                                     GAV.2     
C                                                                          GAV.3     
C     Calculate global average from zonal mean array of field in           GAV.4     
C     isobaric co-ordinates.  Makes uniform surface pressure               GAV.5     
C     approximation: ie all columns given equal weighting.                 GAV.6     
C     Type of average depends on layer mean values in 4th argument         GAV.7     
C     G(LM) (see calls in GDIAG):                                          GAV.8     
C          G = DSIGMA                  :  global mass average of F.        GAV.9     
C          G = DSRSI  = DSIGMA/SIGMA   :  global mass average of F/p.      GAV.10    
C          G = SDSRSI = STAB*DSRSI     :  stability weighted average.      GAV.11    
C                                                                          GAV.12    
C     Input arguments:                                                     GAV.13    
C          F    :  real array of zonal means to be averaged.               GAV.14    
C          GWT  :  real array of Gaussian weights, suitably normalised     GAV.15    
C                  for hemispheric or global averaging.                    GAV.16    
C          JM   :  number of Gaussian latitudes, hemispheric or global     GAV.17    
C                  as in model run.                                        GAV.18    
C          G    :  real array of layer means defining type of averaging.   GAV.19    
C          LM   :  number of levels.                                       GAV.20    
C          TEMP :  real workspace array.                                   GAV.21    
C     On output GAV contains global average and TEMP contains layer        GAV.22    
C     means.  Other arguments unchanged.                                   GAV.23    
C                                                                          GAV.24    
      REAL F(JM,LM),G(LM),TEMP(LM),GWT(JM)                                 GAV.25    
C                                                                          GAV.26    
      DO 10 L=1,LM                                                         GAV.27    
      TEMP(L)=SDOT(JM,GWT(1),1,F(1,L),1)                                   GAV.28    
  10  CONTINUE                                                             GAV.29    
      GAV=SDOT(LM,TEMP(1),1,G(1),1)                                        GAV.30    
C                                                                          GAV.31    
      RETURN                                                               GAV.32    
      END                                                                  GAV.33    
C     ****************************************************************     GAV.34    
*DECK GDIAG                                                                GDIAG.1     
      SUBROUTINE GDIAG                                                     GDIAG.2     
C                                                                          GDIAG.3     
C     Perform global energetics analysis using Entropic Potential          GDIAG.4     
C     Energy (EPE) and Kinetic Energy (KE).  The scheme is defined in      GDIAG.5     
C     Blackburn (1983, PhD thesis, University of Reading) and is a         GDIAG.6     
C     modified version of that defined by Pearce (1978, QJRMS, 104,        GDIAG.7     
C     pp737-755).                                                          GDIAG.8     
C                                                                          GDIAG.9     
C                  l------l                l------l                        GDIAG.10    
C          --Gz----l  NZ  l------Czz-------l  KZ  l----Dz--                GDIAG.11    
C                  l------l                l------l                        GDIAG.12    
C                     l    \              /   l                            GDIAG.13    
C                     l    Cnsz        Csz    l                            GDIAG.14    
C                     l       \        /      l                            GDIAG.15    
C                    Cnze      l------l       l                            GDIAG.16    
C          --Gs-------l--------l  NS  l     Ckze                           GDIAG.17    
C                     l        l------l       l                            GDIAG.18    
C                     l       /        \      l                            GDIAG.19    
C                     l    Cnse        Cse    l                            GDIAG.20    
C                     l    /              \   l                            GDIAG.21    
C                  l------l                l------l                        GDIAG.22    
C          --Ge----l  NE  l------Cee-------l  KE  l----De--                GDIAG.23    
C                  l------l                l------l                        GDIAG.24    
C                                                                          GDIAG.25    
C     Extra terms calculated are:                                          GDIAG.26    
C          TE = NE  + KE     total eddy energy,                            GDIAG.27    
C          Cz = Czz + Csz    total conversion from EPE to KZ,              GDIAG.28    
C          Ce = Cee + Cse    total conversion from EPE to KE.              GDIAG.29    
C     Energies are given in Joules/m2 and conversions in Watts/m2.         GDIAG.30    
C     For values in J/kg and W/kg, divide by the unit area mass, P0/GA.    GDIAG.31    
C     All global integrals are over mass and give equal weighting to       GDIAG.32    
C     all columns by integrating from p=0 to p=P0.                         GDIAG.33    
C                                                                          GDIAG.34    
C     This routine is called at each analysis time to compute the          GDIAG.35    
C     instantaneous energies and conversions and to increment the          GDIAG.36    
C     time averages.  The time series is built up on channel NCGEN and     GDIAG.37    
C     is read at the end of the run when GDIAG is called with KOUNT<0.     GDIAG.38    
C     The time series and averages are then printed and optionally         GDIAG.39    
C     written to channel NCPLOT(1) for plotting in a subsequent program.   GDIAG.40    
C                                                                          GDIAG.41    
*CALL PARAM1                                                               GDIAG.42    
*CALL PARAM2                                                               GDIAG.43    
*CALL BATS                                                                 GDIAG.44    
*CALL BLANK                                                                GDIAG.45    
*CALL COMGEN                                                               GDIAG.46    
*CALL COMIOC                                                               GDIAG.47    
*CALL LEGAU                                                                GDIAG.48    
*CALL OUTCON                                                               GDIAG.49    
*CALL SERIES                                                               GDIAG.50    
*CALL ZONAV                                                                GDIAG.51    
      REAL STAB(NL),GAMDS(NL),DSRSI(NL),SDSRSI(NL),TEMP(NL)                GDIAG.52    
     ;    ,TMSQ(NL),HMTM(NL),WTMN(NL)                                      GDIAG.53    
      REAL TEQV(NTERM5),SEQV(NTERM5)                                       GDIAG.54    
      EQUIVALENCE (TEQV(1),TNS),(SEQV(1),SNS)                              GDIAG.55    
      CHARACTER IYLAB*30,IYLABA*30,IYLABB*30,IXLAB*22,ICAN(6)*3            GDIAG.56    
     :         ,ICANA(15)*3,LTEMP*8                                        GDIAG.57    
      SAVE IYLAB,IYLABA,IYLABB,IXLAB,ICAN,LTEMP                            GDIAG.58    
C                                                                          GDIAG.59    
      DATA IYLAB /'              ENERGIES*.'/                              GDIAG.60    
      DATA IYLABA/'          ENERGY CONVERSIONS*.'/                        GDIAG.61    
      DATA IYLABB/'          KE IN VARIOUS M*.'/                           GDIAG.62    
      DATA IXLAB /'    TIME IN DAYS*.'/                                    GDIAG.63    
      DATA LTEMP /'      *.'/                                              GDIAG.64    
      DATA ICAN  /' NS',' NZ',' NE',' KZ',' KE','   '/                     GDIAG.65    
     :    ,ICANA /' CZ',' CE','NZE','KZE','NSZ','NSE'                      GDIAG.66    
     :           ,' GS',' GZ',' GE',' DZ',' DE'                            GDIAG.67    
     :           ,'IGZ','IGE','IDZ','IDE'/                                 GDIAG.68    
C                                                                          GDIAG.69    
 6000 FORMAT(' GLOBAL ENERGETICS AT DAY ',F10.2)                           BUGS5.29    
 6010 FORMAT(' TIME AVERAGE GLOBAL DIAGNOSTICS')                           GDIAG.71    
 6020 FORMAT(' GLOBAL MEANS: TEMP  OMEGA  HEATING  STABILITY =',4F12.5)    GDIAG.72    
 6030 FORMAT(' ***GDIAG : TIME SERIES OF GLOBAL ENERGETICS ON PLOT FILE'   GDIAG.73    
     :      ,' STOPS AT DAY',F10.2)                                        GDIAG.74    
 6040 FORMAT(' ENERGETICS TIME SERIES RUNS FROM DAY ',F10.2                BUGS5.30    
     :      ,' TO DAY ',F10.2)                                             BUGS5.31    
 6100 FORMAT(1P,'     NS=',E11.4,'     NZ=',E11.4                          GDIAG.77    
     :         ,'     NE=',E11.4,'     KZ=',E11.4                          GDIAG.78    
     :         ,'     KE=',E11.4,'     TE=',E11.4,'    J/M2')              GDIAG.79    
 6110 FORMAT(1P,'   CNZE=',E11.4,'    CZZ=',E11.4,'    CSZ=',E11.4         GDIAG.80    
     :         ,'   CNSZ=',E11.4,'     CZ=',E11.4,'    W/M2'               GDIAG.81    
     :         /'   CKZE=',E11.4,'    CEE=',E11.4,'    CSE=',E11.4         GDIAG.82    
     :         ,'   CNSE=',E11.4,'     CE=',E11.4,'    W/M2')              GDIAG.83    
 6120 FORMAT(1P,'     GS=',E11.4,'     GZ=',E11.4,'     GE=',E11.4         GDIAG.84    
     :         ,'     DZ=',E11.4,'     DE=',E11.4,'    W/M2')              GDIAG.85    
 6130 FORMAT(1P,'        ',  11X,'    IGZ=',E11.4,'    IGE=',E11.4         GDIAG.86    
     :         ,'    IDZ=',E11.4,'    IDE=',E11.4,'    W/M2')              GDIAG.87    
 6140 FORMAT(1P,'    RNS=',E11.4,'    RNZ=',E11.4,'    RKZ=',E11.4         GDIAG.88    
     :         ,'    DRZ=',E11.4,'    DRE=',E11.4,'    W/M2')              GDIAG.89    
C                                                                          GDIAG.90    
      IF (KOUNT.LT.0) GOTO 100                                             GDIAG.91    
C                                                                          GDIAG.92    
C     ----------------------------------------------------------------     GDIAG.93    
C                                                                          GDIAG.94    
C     Calculate global averages for one analysis time                      GDIAG.95    
C     and increment time averages.                                         GDIAG.96    
C                                                                          GDIAG.97    
      IF (KOUNT.EQ.KSTART) THEN                                            GDIAG.98    
         NPTS5=0                                                           GDIAG.99    
         REWIND NCGEN                                                      GDIAG.100   
         IF (LTAV) THEN                                                    GDIAG.101   
            DO 10 N=1,NTERM5                                               GDIAG.102   
   10       SEQV(N)=0.                                                     GDIAG.103   
         ENDIF                                                             GDIAG.104   
      ENDIF                                                                GDIAG.105   
C                                                                          GDIAG.106   
C     Zonal and isobaric means required for global energetics.             GDIAG.107   
C                                                                          GDIAG.108   
      CALL DLSGCR(1,TMN,RGG,STAB,1,NL)                                     GDIAG.109   
      GAML=1./(AKAP*TMNN)                                                  GDIAG.110   
      DO 20 L=1,NL                                                         GDIAG.111   
      STAB(L)=GAML*STAB(L)                                                 GDIAG.112   
      GAMDS(L)=GAML*DSIGMA(L)                                              GDIAG.113   
      DSRSI(L)=DSIGMA(L)/SIGMA(L)                                          GDIAG.114   
      SDSRSI(L)=STAB(L)*DSRSI(L)                                           GDIAG.115   
      TMSQ(L)=(TMN(L)-TMNN)*(TMN(L)-TMNN)                                  GDIAG.116   
      HMTM(L)=(HMN(L)-HMNN)*(TMN(L)-TMNN)                                  GDIAG.117   
   20 CONTINUE                                                             GDIAG.118   
      STMNN=SDOT(NL,STAB(1),1,DSIGMA(1),1)                                 GDIAG.119   
      DO 30 L=1,NL                                                         GDIAG.120   
      WTMN(L)=SDOT(JGG,WTBR(1,L),1,GWT(1),1)                               GDIAG.121   
      DO 30 J=1,JGG                                                        GDIAG.122   
      DUMNZ(J,L)=(TBR(J,L)-TMN(L))*(TBR(J,L)-TMN(L))                       GDIAG.123   
      DUMCN(J,L)=VTBR(J,L)*DTBDMU(J,L)*GAML*CS(J)                          GDIAG.124   
     :          +(WTBR(J,L)-WTMN(L))*(STBP(J,L)*GAML-STAB(L))/SIGMA(L)     GDIAG.125   
      DUMCK(J,L)=CSSQ(J)*(UVBR(J,L)*DUBDMU(J,L)+VVBR(J,L)*DVBDMU(J,L))     GDIAG.126   
     :          +UWBR(J,L)*UBRP(J,L)+VWBR(J,L)*VBRP(J,L)                   GDIAG.127   
     :          -VBR(J,L)*AKE(J,L)*2.*SI(J)/CS(J)                          GDIAG.128   
   30 CONTINUE                                                             GDIAG.129   
C                                                                          GDIAG.130   
C     Calculate globally averaged energetics values.                       GDIAG.131   
C                                                                          GDIAG.132   
      EFAC=CG*P0/GA                                                        GDIAG.133   
      CFAC=EFAC*WW                                                         GDIAG.134   
      TNZ= GAV(DUMNZ,GWT,JGG,GAMDS ,NL,TEMP)*EFAC*.5                       GDIAG.135   
      TNE= GAV(TTBR ,GWT,JGG,GAMDS ,NL,TEMP)*EFAC*.5                       GDIAG.136   
      TKZ= GAV(AKZ  ,GWT,JGG,DSIGMA,NL,TEMP)*EFAC                          GDIAG.137   
      TKE= GAV(AKE  ,GWT,JGG,DSIGMA,NL,TEMP)*EFAC                          GDIAG.138   
      TGZ= GAV(HBTBR,GWT,JGG,GAMDS ,NL,TEMP)*CFAC                          GDIAG.139   
      TGE= GAV(HTBR ,GWT,JGG,GAMDS ,NL,TEMP)*CFAC                          GDIAG.140   
      TDZ=-GAV(FUZR ,GWT,JGG,DSIGMA,NL,TEMP)*CFAC                          GDIAG.141   
      TDE=-GAV(FUER ,GWT,JGG,DSIGMA,NL,TEMP)*CFAC                          GDIAG.142   
      TCZ=-GAV(WBTBR,GWT,JGG,DSRSI ,NL,TEMP)*CFAC                          GDIAG.143   
      TCE=-GAV(WTBR ,GWT,JGG,DSRSI ,NL,TEMP)*CFAC                          GDIAG.144   
      TCSZ=TCZ*STMNN                                                       GDIAG.145   
      TCSE=TCE*STMNN                                                       GDIAG.146   
      TCZZ=TCZ-TCSZ                                                        GDIAG.147   
      TCEE=TCE-TCSE                                                        GDIAG.148   
      TCNSZ=-GAV(WBTBR,GWT,JGG,SDSRSI,NL,TEMP)*CFAC - TCSZ                 GDIAG.149   
      TCNSE=-GAV(WTBR ,GWT,JGG,SDSRSI,NL,TEMP)*CFAC - TCSE                 GDIAG.150   
      TCNZE=-GAV(DUMCN,GWT,JGG,DSIGMA,NL,TEMP)*CFAC                        GDIAG.151   
      TCKZE=-GAV(DUMCK,GWT,JGG,DSIGMA,NL,TEMP)*CFAC                        GDIAG.152   
      TNS = SDOT(NL,TMSQ(1)  ,1,GAMDS(1),1)*EFAC*.5                        GDIAG.153   
      TGS = SDOT(NL,HMTM(1)  ,1,GAMDS(1),1)*CFAC                           GDIAG.154   
      FIGZ=-SDOT(NL,GAMDS(1) ,1,TIGZ(1) ,1)*AKK                            GDIAG.155   
      FIGE=-SDOT(NL,GAMDS(1) ,1,TIGE(1) ,1)*AKK                            GDIAG.156   
      FIDZ= SDOT(NL,DSIGMA(1),1,TIDZ(1) ,1)*AKK                            GDIAG.157   
      FIDE= SDOT(NL,DSIGMA(1),1,TIDE(1) ,1)*AKK                            GDIAG.158   
      FRNS= SDOT(NL,DSIGMA(1),1,TRNS(1) ,1)*DAMP                           GDIAG.159   
      FRNZ=-SDOT(NL,GAMDS(1) ,1,TRNZ(1) ,1)*DAMP                           GDIAG.160   
      FRKZ= SDOT(NL,DSIGMA(1),1,TRKZ(1) ,1)*DAMP                           GDIAG.161   
      FDRZ= SDOT(NL,DSIGMA(1),1,TDRZ(1) ,1)                                GDIAG.162   
      FDRE= SDOT(NL,DSIGMA(1),1,TDRE(1) ,1)                                GDIAG.163   
C                                                                          GDIAG.164   
C     Accumulate time averages.                                            GDIAG.165   
C                                                                          GDIAG.166   
      IF (LTAV) THEN                                                       GDIAG.167   
         FD=FTAV                                                           GDIAG.168   
         IF (KOUNT.EQ.KSTART.OR.KOUNT.EQ.KEND) FD=.5*FD                    GDIAG.169   
         DO 40 N=1,NTERM5                                                  GDIAG.170   
   40    SEQV(N)=SEQV(N)+TEQV(N)*FD                                        GDIAG.171   
      ENDIF                                                                GDIAG.172   
C                                                                          GDIAG.173   
C     Write instantaneous values and also time averages at KEND.           GDIAG.174   
C                                                                          GDIAG.175   
      WRITE(NCGEN) KOUNT,DAY                                               GDIAG.176   
      WRITE(NCGEN) (TEQV(N),N=1,NTERM5),TMNN,WMNN,HMNN,STMNN               GDIAG.177   
      IF (KOUNT.EQ.KEND.AND.LTAV) THEN                                     GDIAG.178   
         JOUNT=-999                                                        GDIAG.179   
         TDAY=-999.                                                        GDIAG.180   
         WRITE(NCGEN) JOUNT,TDAY                                           GDIAG.181   
         WRITE(NCGEN) (SEQV(N),N=1,NTERM5),TDAY,TDAY,TDAY,TDAY             GDIAG.182   
      ENDIF                                                                GDIAG.183   
C                                                                          GDIAG.184   
C     Copy energetics values into time series arrays for plotting.         GDIAG.185   
C     These are sorted and copied to plot file at end of run.              GDIAG.186   
C                                                                          GDIAG.187   
      IF (LENCOP.AND.NPTS5.LT.NPMAX5) THEN                                 GDIAG.188   
         NPTS5=NPTS5+1                                                     GDIAG.189   
         IF (NPTS5.EQ.NPMAX5) WRITE(6,6030) DAY                            GDIAG.190   
         ADAY(NPTS5)=DAY                                                   GDIAG.191   
         AEN(NPTS5,1)=TNS                                                  GDIAG.192   
         AEN(NPTS5,2)=TNZ                                                  GDIAG.193   
         AEN(NPTS5,3)=TNE                                                  GDIAG.194   
         AEN(NPTS5,4)=TKZ                                                  GDIAG.195   
         AEN(NPTS5,5)=TKE                                                  GDIAG.196   
         ACONV(NPTS5, 1)= TCZ                                              GDIAG.197   
         ACONV(NPTS5, 2)= TCE                                              GDIAG.198   
         ACONV(NPTS5, 3)= TCNZE                                            GDIAG.199   
         ACONV(NPTS5, 4)= TCKZE                                            GDIAG.200   
         ACONV(NPTS5, 5)= TCNSZ                                            GDIAG.201   
         ACONV(NPTS5, 6)= TCNSE                                            GDIAG.202   
         ACONV(NPTS5, 7)= TGS                                              GDIAG.203   
         ACONV(NPTS5, 8)= TGZ                                              GDIAG.204   
         ACONV(NPTS5, 9)= TGE                                              GDIAG.205   
         ACONV(NPTS5,10)=-TDZ                                              GDIAG.206   
         ACONV(NPTS5,11)=-TDE                                              GDIAG.207   
         ACONV(NPTS5,12)= FIGZ                                             GDIAG.208   
         ACONV(NPTS5,13)= FIGE                                             GDIAG.209   
         ACONV(NPTS5,14)=-FIDZ                                             GDIAG.210   
         ACONV(NPTS5,15)=-FIDE                                             GDIAG.211   
      ENDIF                                                                GDIAG.212   
C                                                                          GDIAG.213   
      RETURN                                                               GDIAG.214   
C                                                                          GDIAG.215   
C     ----------------------------------------------------------------     GDIAG.216   
C                                                                          GDIAG.217   
C     End of run. Read time series of global terms and print.              GDIAG.218   
C                                                                          GDIAG.219   
  100 CONTINUE                                                             GDIAG.220   
      REWIND NCGEN                                                         GDIAG.221   
      IF (NPC5.NE.6) WRITE(NPC5,'(/////)')                                 GDIAG.222   
      WRITE(6,'(/////)')                                                   GDIAG.223   
C                                                                          GDIAG.224   
  110 CONTINUE                                                             GDIAG.225   
      READ(NCGEN) JOUNT,TDAY                                               GDIAG.226   
      READ(NCGEN) (TEQV(N),N=1,NTERM5),TMNN,WMNN,HMNN,STMNN                GDIAG.227   
      IF (JOUNT.GE.0) THEN                                                 GDIAG.228   
         IF (NPC5.NE.6) WRITE(NPC5,6000) TDAY                              GDIAG.229   
         WRITE(6,6000) TDAY                                                GDIAG.230   
      ELSE                                                                 GDIAG.231   
         IF (NPC5.NE.6) WRITE(NPC5,6010)                                   GDIAG.232   
         WRITE(6,6010)                                                     GDIAG.233   
      ENDIF                                                                GDIAG.234   
      IF (JOUNT.GE.0) THEN                                                 GDIAG.235   
         WMNN=WMNN*CMBHR                                                   GDIAG.236   
         TMNN=TMNN*CT                                                      GDIAG.237   
         HMNN=HMNN*CTT                                                     GDIAG.238   
         IF (NPC5.NE.6) WRITE(NPC5,6020) TMNN,WMNN,HMNN,STMNN              GDIAG.239   
         WRITE(6,6020) TMNN,WMNN,HMNN,STMNN                                GDIAG.240   
      ENDIF                                                                GDIAG.241   
      TEE=TKE+TNE                                                          GDIAG.242   
      TCZ=TCZZ+TCSZ                                                        GDIAG.243   
      TCE=TCEE+TCSE                                                        GDIAG.244   
      IF (NPC5.NE.6) THEN                                                  GDIAG.245   
         WRITE(NPC5,6100) TNS,TNZ,TNE,TKZ,TKE,TEE                          GDIAG.246   
         WRITE(NPC5,6110) TCNZE,TCZZ,TCSZ,TCNSZ,TCZ                        GDIAG.247   
     :                   ,TCKZE,TCEE,TCSE,TCNSE,TCE                        GDIAG.248   
         WRITE(NPC5,6120) TGS,TGZ,TGE,TDZ,TDE                              GDIAG.249   
         WRITE(NPC5,6130) FIGZ,FIGE,FIDZ,FIDE                              GDIAG.250   
         WRITE(NPC5,6140) FRNS,FRNZ,FRKZ,FDRZ,FDRE                         GDIAG.251   
      ENDIF                                                                GDIAG.252   
      WRITE(6,6100) TNS,TNZ,TNE,TKZ,TKE,TEE                                GDIAG.253   
      WRITE(6,6110) TCNZE,TCZZ,TCSZ,TCNSZ,TCZ                              GDIAG.254   
     :             ,TCKZE,TCEE,TCSE,TCNSE,TCE                              GDIAG.255   
      WRITE(6,6120) TGS,TGZ,TGE,TDZ,TDE                                    GDIAG.256   
      WRITE(6,6130) FIGZ,FIGE,FIDZ,FIDE                                    GDIAG.257   
      WRITE(6,6140) FRNS,FRNZ,FRKZ,FDRZ,FDRE                               GDIAG.258   
C                                                                          GDIAG.259   
      IF (JOUNT.GE.0.AND.JOUNT.LT.KEND) GOTO 110                           GDIAG.260   
      IF (JOUNT.EQ.KEND.AND.LTAV) GOTO 110                                 GDIAG.261   
C                                                                          GDIAG.262   
C     Sort and write time series of energies and conversions               GDIAG.263   
C     to plot file for use in subsequent job if required.                  GDIAG.264   
C                                                                          GDIAG.265   
      IF (.NOT.LENCOP) RETURN                                              GDIAG.266   
      IXT=3                                                                GDIAG.267   
      IYT=3                                                                GDIAG.268   
      IANC=-1                                                              GDIAG.269   
      XU=XUEN                                                              GDIAG.270   
      YL=335.                                                              GDIAG.271   
      WRITE(IYLAB (1:8),'(F8.3)') RNTAPE                                   GDIAG.272   
      WRITE(IYLABA(1:8),'(F8.3)') RNTAPE                                   GDIAG.273   
      WRITE(IYLABB(1:8),'(F8.3)') RNTAPE                                   GDIAG.274   
      DO 200 L=1,5                                                         GDIAG.275   
  200 ENMX(L)=ENMN(L)+ENRNGE                                               GDIAG.276   
C                                                                          GDIAG.277   
      NBEG=1                                                               GDIAG.278   
      NEND=NBEG+ISPLIT                                                     GDIAG.279   
  210 IF (NEND.GT.NPTS5) NEND=NPTS5                                        GDIAG.280   
      IF (NPC5.NE.6) WRITE(NPC5,6040) ADAY(NBEG),ADAY(NEND)                GDIAG.281   
      WRITE(6,6040) ADAY(NBEG),ADAY(NEND)                                  GDIAG.282   
      XMN=ADAY(NBEG)                                                       GDIAG.283   
      XL=ADAY(NEND)-XMN                                                    GDIAG.284   
      IXI=NINT(XL)                                                         GDIAG.285   
      XL=XL/XU                                                             GDIAG.286   
      N=NEND-NBEG+1                                                        GDIAG.287   
C                                                                          GDIAG.288   
      LNPIC=.TRUE.                                                         SUNMOD.61    
      DO 220 I=1,5                                                         GDIAG.290   
      LTEMP(4:6)=ICAN(I)                                                   GDIAG.291   
      WRITE(NCPLOT(1)) N,IXT,IYT,LTEMP,IANC,IXLAB,IYLAB,XL,XU,XMN          GDIAG.292   
     :         ,IXI,YL,ENMX(I),ENMN(I),IYEN,LNPIC                          GDIAG.293   
      WRITE(NCPLOT(1)) (ADAY(K),K=NBEG,NEND),(AEN(K,I),K=NBEG,NEND)        GDIAG.294   
  220 LNPIC=.FALSE.                                                        SUNMOD.62    
C                                                                          GDIAG.296   
      I2=0                                                                 GDIAG.297   
      DO 240 NPLOT=1,3                                                     GDIAG.298   
      IF (NPLOT.EQ.1) NI=6                                                 GDIAG.299   
      IF (NPLOT.EQ.2) NI=5                                                 GDIAG.300   
      IF (NPLOT.EQ.3) NI=4                                                 GDIAG.301   
      I1=I2+1                                                              GDIAG.302   
      I2=I1+NI-1                                                           GDIAG.303   
      LNPIC=.TRUE.                                                         SUNMOD.63    
      DO 230 I=I1,I2                                                       GDIAG.305   
      LTEMP(4:6)=ICANA(I)                                                  GDIAG.306   
      WRITE(NCPLOT(1)) N,IXT,IYT,LTEMP,IANC,IXLAB,IYLABA,XL,XU,XMN         GDIAG.307   
     :         ,IXI,YL,ECONMX,ECONMN,IYCON,LNPIC                           GDIAG.308   
      WRITE(NCPLOT(1)) (ADAY(K),K=NBEG,NEND),(ACONV(K,I),K=NBEG,NEND)      GDIAG.309   
  230 LNPIC=.FALSE.                                                        SUNMOD.64    
  240 CONTINUE                                                             GDIAG.311   
C                                                                          GDIAG.312   
      NBEG=NEND                                                            GDIAG.313   
      NEND=NBEG+ISPLIT                                                     GDIAG.314   
      IF (NBEG.LT.NPTS5) GOTO 210                                          GDIAG.315   
C                                                                          GDIAG.316   
      RETURN                                                               GDIAG.317   
      END                                                                  GDIAG.318   
C     ****************************************************************     GDIAG.319   
*DECK INIMSK                                                               INIMSK.1     
      SUBROUTINE INIMSK                                                    INIMSK.2     
C                                                                          INIMSK.3     
C     Initialise orographic mask fields for current analysis time.         INIMSK.4     
C     Write fields to data transfer file (UTF) if required.                INIMSK.5     
C                                                                          INIMSK.6     
*CALL PARAM1                                                               INIMSK.7     
*CALL PARAM2                                                               INIMSK.8     
*CALL BATS                                                                 INIMSK.9     
*CALL BLANK                                                                INIMSK.10    
*CALL COMIOC                                                               INIMSK.11    
*CALL COMMSK                                                               INIMSK.12    
*CALL COMPRL                                                               INIMSK.13    
*CALL COMROG                                                               INIMSK.14    
*CALL OUTCON                                                               INIMSK.16    
*CALL MSKEQV                                                               INIMSK.17    
      REAL P3MIN(JGG),P3AV(JGG)                                            INIMSK.18    
      EQUIVALENCE (P3MIN(1),P3MSK(1,1)),(P3AV(1),P3MSK(1,2))               INIMSK.19    
      LOGICAL LOM2,LOM3                                                    INIMSK.20    
      CHARACTER*25 MNAME2,MNAME3                                           INIMSK.21    
C                                                                          INIMSK.22    
      DATA MNAME2/'MASK2 SURFACE PRESSURE   '/                             INIMSK.23    
      DATA MNAME3/'MASK3 MIN AND AV PRESSURE'/                             INIMSK.24    
      SAVE MNAME2,MNAME3                                                   INIMSK.25    
C                                                                          INIMSK.26    
 6000 FORMAT(/' ***ABORT IN INIMSK: 2-D MASK ARRAY TOO LARGE FOR'          INIMSK.27    
     :       ,' EQUIVALENCING IN GRIDP: IDH, IGMX =',2I10)                 INIMSK.28    
C                                                                          INIMSK.29    
C     Check common GRIDP is long enough for equivalenced mask array        INIMSK.30    
C     Must occupy only from UG to PMSLG, to avoid isentropic arrays.       INIMSK.31    
C***  NB.  This calculation depends on the size/ordering of GRIDP.         INIMSK.32    
C                                                                          INIMSK.33    
      IGMX=(14*NL+4)*IGC                                                   INIMSK.34    
      IF (IDH.GT.IGMX) THEN                                                INIMSK.35    
         WRITE(6,6000) IDH,IGMX                                            INIMSK.36    
         CALL ABORT                                                        INIMSK.37    
      ENDIF                                                                INIMSK.38    
C                                                                          INIMSK.39    
C     Preset full surface pressure mask array to zero.                     INIMSK.40    
C     Set mask switches for this analysis time.  Return if no masks.       INIMSK.41    
C                                                                          INIMSK.42    
      DO 10 J=1,JGGP                                                       INIMSK.43    
      DO 10 I=1,MGP                                                        INIMSK.44    
   10 P2MSK(I,J)=0.                                                        INIMSK.45    
      LOM2=LMSK2.AND.(LOUTA.OR.LOUTF)                                      INIMSK.46    
      LOM3=LMSK3.AND.(LOUTA.OR.LOUTF)                                      INIMSK.47    
      IF (.NOT.(LOM2.OR.LOM3)) RETURN                                      INIMSK.48    
C                                                                          INIMSK.49    
C     Read surface pressure field directly into lat-long mask array.       INIMSK.50    
C                                                                          INIMSK.51    
      NC=NCGP(11)                                                          INIMSK.52    
      REWIND NC                                                            INIMSK.53    
      DO 20 J=1,JG                                                         INIMSK.54    
      IF (NHEM.EQ.1) THEN                                                  INIMSK.55    
         READ(NC) (P2MSK(I,J),I=1,MG)                                      INIMSK.56    
      ELSE                                                                 INIMSK.57    
         JS=JGGP+1-J                                                       INIMSK.58    
         READ(NC) (P2MSK(I,J),I=1,MG),(DUM,I=1,2),(P2MSK(I,JS),I=1,MG)     INIMSK.59    
      ENDIF                                                                INIMSK.60    
   20 CONTINUE                                                             INIMSK.61    
      REWIND NC                                                            INIMSK.62    
C                                                                          INIMSK.63    
C     Normalise so that 0 -> P0 becomes 0 -> 1000.                         INIMSK.64    
C     Obtain zonal mean and minimum surface pressure at each latitude.     INIMSK.65    
C     Use to form remaining mask fields.                                   INIMSK.66    
C                                                                          INIMSK.67    
      PMFAC=1000.                                                          INIMSK.68    
      DO 50 IHEM=1,NHEM                                                    INIMSK.69    
      DO 50 J=1,JG                                                         INIMSK.70    
      JJ=(2-IHEM)*J + (IHEM-1)*(JGGP+1-J)                                  INIMSK.71    
      JZ=JJ-(IHEM-1)                                                       INIMSK.72    
      DO 40 I=1,MG                                                         INIMSK.73    
   40 P2MSK(I,JJ)=PMFAC*P2MSK(I,JJ)                                        INIMSK.74    
      P3AV(JZ)=SSUM(MG,P2MSK(1,JJ),1)*RMG                                  INIMSK.75    
      IM=ISMIN(MG,P2MSK(1,JJ),1)                                           INIMSK.76    
      P3MIN(JZ)=P2MSK(IM,JJ)                                               INIMSK.77    
   50 CONTINUE                                                             INIMSK.78    
C                                                                          INIMSK.79    
C     Lat-long mask: prepare and write to UTF if required.                 INIMSK.89    
C     Check that lowest pressure level intersects orography.               INIMSK.90    
C                                                                          INIMSK.91    
      IF (LOM2) THEN                                                       INIMSK.92    
         CALL GVPREP(P2MSK,0.,0.,CL,1,GNORM,GINC,ICNT,P2MIN,P2MAX,IFAIL)   INIMSK.93    
         IF (((PPR(NLPR)*PMFAC).GT.P2MIN).AND.LOUTA) THEN                  INIMSK.94    
            CALL WTFUTF(P2MSK,MGP,JGGP,IZGTYP,0,3,2,1,1                    INIMSK.95    
     :                 ,P2MIN,P2MAX,0.,DAY,MNAME2,25,NPCA,IFAIL)           INIMSK.96    
         ENDIF                                                             INIMSK.97    
      ENDIF                                                                INIMSK.98    
C                                                                          INIMSK.99    
C     Zonal mean mask: write to UTF if required.                           INIMSK.100   
C                                                                          INIMSK.101   
      IF (LOM3.AND.LOUTA) CALL WTFUTF(P3MSK,JGG,2,11,0,4,2,1,1             INIMSK.102   
     :                               ,0.,0.,0.,DAY,MNAME3,25,NPCA,IFAIL)   INIMSK.103   
C                                                                          INIMSK.104   
      RETURN                                                               INIMSK.105   
      END                                                                  INIMSK.106   
C     ****************************************************************     INIMSK.107   
*DECK OPGRID                                                               OPGRID.1     
      SUBROUTINE OPGRID                                                    OPGRID.2     
C                                                                          OPGRID.3     
C     Organise output of grid point data on model or pressure levels.      OPGRID.4     
C     NB.  Uses common SPECTR as workspace for GPV array.                  OPGRID.5     
C                                                                          OPGRID.6     
*CALL PARAM1                                                               OPGRID.7     
*CALL PARAM2                                                               OPGRID.8     
*CALL BATS                                                                 OPGRID.9     
*CALL BLANK                                                                OPGRID.10    
*CALL COMIOC                                                               OPGRID.11    
*CALL COMPRL                                                               OPGRID.12    
*CALL COMROG                                                               OPGRID.13    
*CALL OUTCON                                                               OPGRID.15    
*CALL PHYS                                                                 OPGRID.16    
*CALL SPECTR                                                               OPGRID.17    
      REAL GPV(IGD*JG),DFAC(NSG)                                           OPGRID.18    
      EQUIVALENCE (GPV(1),Z(1))                                            OPGRID.19    
      LOGICAL LOUTGR,LOUTPL                                                OPGRID.20    
      CHARACTER NAMES(NSG)*50                                              OPGRID.21    
      SAVE NAMES                                                           OPGRID.22    
C                                                                          OPGRID.23    
      DATA (NAMES(N),N=1,NSG)/                                             OPGRID.24    
     1 'STREAM FUNCTION                          M2/S     '                OPGRID.25    
     2,'RELATIVE VORTICITY                       S-1      '                OPGRID.26    
     3,'DIVERGENCE                               S-1      '                OPGRID.27    
     4,'OMEGA                                    MB/HR    '                OPGRID.28    
     5,'ZONAL WIND                               M/S      '                OPGRID.29    
     6,'MERIDIONAL WIND                          M/S      '                OPGRID.30    
     7,'TEMPERATURE                              DEG C    '                OPGRID.31    
     8,'GEOPOTENTIAL HEIGHT                      METRES   '                OPGRID.32    
     9,'SPECIFIC HUMIDITY                        G/KG     '                OPGRID.33    
     :,'DIABATIC HEATING                         K/DAY    '                OPGRID.34    
     1,'SURFACE PRESSURE                         MB       '                OPGRID.35    
     2,'MSL PRESSURE                             MB       '                OPGRID.36    
     :/                                                                    OPGRID.37    
C                                                                          OPGRID.38    
 6000 FORMAT(' PROCESSING SIGMA G-P FIELDS  AT DAY',F10.2,' KOUNT=',I10)   OPGRID.39    
C                                                                          OPGRID.40    
C     Write headers.                                                       OPGRID.41    
C                                                                          OPGRID.42    
      IF (NPC2.NE.6) THEN                                                  OPGRID.43    
         IF (LOUTP) WRITE(NPC2,'(///)')                                    OPGRID.44    
         WRITE(NPC2,6000) DAY,KOUNT                                        OPGRID.45    
      ENDIF                                                                OPGRID.46    
      WRITE(6,6000) DAY,KOUNT                                              OPGRID.47    
C                                                                          OPGRID.48    
C     Dimensionalising factors.                                            OPGRID.49    
C                                                                          OPGRID.50    
      DFAC(1)=RADEA*CV                                                     OPGRID.51    
      DFAC(2)=WW                                                           OPGRID.52    
      DFAC(3)=WW                                                           OPGRID.53    
      DFAC(4)=CMBHR                                                        OPGRID.54    
      DFAC(5)=CV                                                           OPGRID.55    
      DFAC(6)=CV                                                           OPGRID.56    
      DFAC(7)=CT                                                           OPGRID.57    
      DFAC(8)=CG/GA                                                        OPGRID.58    
      DFAC(9)=CQ                                                           OPGRID.59    
      DFAC(10)=CTT                                                         OPGRID.60    
      DFAC(11)=P0/100.                                                     OPGRID.61    
      DFAC(12)=P0/100.                                                     OPGRID.62    
C                                                                          OPGRID.63    
C     Loop over fields, each stored on a separate scratch file.            OPGRID.64    
C                                                                          OPGRID.65    
      DO 10 IOUT=1,NSG                                                     OPGRID.66    
      LOUTGR=LSGGR(IOUT)                                                   OPGRID.67    
      LOUTPL=LSGPL(IOUT)                                                   OPGRID.68    
      IF (.NOT.((LOUTP.AND.LOUTGR)                                         OPGRID.69    
     :          .OR.((LOUTF.OR.LOUTA).AND.LOUTPL))) GOTO 10                OPGRID.70    
      IF (IOUT.EQ.10.AND.KOUNT.LE.KBEGP) GOTO 10                           OPGRID.71    
      IF (IOUT.EQ.11.AND..NOT.LROG) GOTO 10                                OPGRID.72    
      NC=NCGP(IOUT)                                                        OPGRID.73    
      NLOUT=NL                                                             OPGRID.74    
      IF (LINTP2) NLOUT=NLPR                                               OPGRID.75    
      IF (IOUT.EQ.11) NLOUT=1                                              OPGRID.76    
      IF (IOUT.EQ.12) NLOUT=1                                              OPGRID.77    
      IPTYP=IZGTYP                                                         OPGRID.78    
      ICSTYL=0                                                             OPGRID.79    
      IF ((IOUT.EQ.1.OR.IOUT.EQ.7).AND..NOT.LSGEDY) ICSTYL=1               OPGRID.80    
      AFAC=SGFAC(IOUT)                                                     OPGRID.81    
      FINC=SGINC(IOUT)                                                     OPGRID.82    
      CALL OUTSUB(GPV,NAMES(IOUT),NC,NLOUT,DFAC(IOUT),AFAC,FINC            OPGRID.83    
     :           ,LOUTGR,LOUTPL,IPTYP,ICSTYL,IOUT)                         OPGRID.84    
   10 CONTINUE                                                             OPGRID.85    
C                                                                          OPGRID.86    
      RETURN                                                               OPGRID.87    
      END                                                                  OPGRID.88    
C     ****************************************************************     OPGRID.89    
*DECK OUTSUB                                                               OUTSUB.1     
      SUBROUTINE OUTSUB(GPV,NAME,NC,NLOUT,DFAC,AFAC,CINC                   OUTSUB.2     
     :                 ,LOUTGR,LOUTPL,IPTYP,ICSTYL,IOUT)                   OUTSUB.3     
C                                                                          OUTSUB.4     
C     To print plot and dump a global (multilevel for NLOUT.GT.1) field.   OUTSUB.5     
C     If NC <= 0, GPV contains data, otherwise read from channel NC.       OUTSUB.6     
C     Certain values of IOUT give special functions :                      OUTSUB.7     
C       IOUT=2  :  Subtract planetary vorticity after reading.             OUTSUB.8     
C       IOUT=4  :  Halve the contour interval at level L=NLOUT.            OUTSUB.9     
C       IOUT=5  :  Zonal wind : divide by cos(lat) after reading.          OUTSUB.10    
C       IOUT=6  :  Meridional wind : ditto plus zonal averages are *10.    OUTSUB.11    
C       IOUT=7  :  Temperature : subtract 273.15K to obtain Celcius.       OUTSUB.12    
C       IOUT=12 :  MSL pressure : subtract reference pressure in DFAC.     OUTSUB.13    
C     To avoid all of these for added fields use, eg. IOUT=0.              OUTSUB.14    
C                                                                          OUTSUB.15    
*CALL PARAM1                                                               OUTSUB.16    
*CALL PARAM2                                                               OUTSUB.17    
      PARAMETER(NCNT=50)                                                   OUTSUB.18    
C                                                                          OUTSUB.19    
*CALL BATS                                                                 OUTSUB.20    
*CALL BLANK                                                                OUTSUB.21    
*CALL COMMSK                                                               OUTSUB.22    
*CALL COMPRL                                                               OUTSUB.23    
*CALL DUM                                                                  OUTSUB.24    
*CALL LEGAU                                                                OUTSUB.25    
*CALL OUTCON                                                               OUTSUB.26    
      REAL GPV(MGPP,NHEM,NLOUT,JG)                                         OUTSUB.27    
      REAL GV(MGP,JGGP),GX(MGP,JGGP),GY(MGP,JGGP)                          OUTSUB.28    
      EQUIVALENCE (GV,GVE(1,1)),(GX,GVE(1,2)),(GY,GVE(1,3))                OUTSUB.29    
      REAL CL(NCNT)                                                        OUTSUB.30    
      LOGICAL LPRINT,LPLOT,LDUMP,LOUTGR,LOUTPL,LVEC,LXY,LZ                 OUTSUB.31    
      CHARACTER NAME*50,NAMC*50                                            OUTSUB.32    
C                                                                          OUTSUB.33    
 6000 FORMAT(/' DAY',F10.2,'  NUMBER OF TIME STEPS COMPLETED =',I10)       OUTSUB.34    
C                                                                          OUTSUB.35    
C     Set switches.  Write header.                                         OUTSUB.36    
C                                                                          OUTSUB.37    
      NPLT=1                                                               OUTSUB.38    
      LVEC=.FALSE.                                                         SUNMOD.65    
      LPRINT=LOUTP.AND.LOUTGR                                              BUGS5.32    
      LZ=(LPRINT.AND.LSGGRZ).OR.                                           BUGS5.33    
     :   (LOUTPL.AND.LSGPLZ.AND.(NLOUT.EQ.NL).AND.(LOUTF.OR.LOUTA))        OUTSUB.42    
      IF (LPRINT) WRITE(NPC2,6000) DAY,KOUNT                               OUTSUB.43    
C                                                                          OUTSUB.44    
C     Read data as JG records from scratch file if necessary.              OUTSUB.45    
C                                                                          OUTSUB.46    
      IF (NC.GT.0) THEN                                                    OUTSUB.47    
         REWIND NC                                                         OUTSUB.48    
         DO 10 J=1,JG                                                      OUTSUB.49    
   10    READ(NC) (((GPV(I,IHEM,L,J),I=1,MGPP),IHEM=1,NHEM),L=1,NLOUT)     OUTSUB.50    
         REWIND NC                                                         OUTSUB.51    
      ENDIF                                                                OUTSUB.52    
C                                                                          OUTSUB.53    
C     Dimensionalise and add offset as required.                           OUTSUB.54    
C     Winds are obtained by dividing by cos(lat).                          OUTSUB.55    
C                                                                          OUTSUB.56    
      DFACT=DFAC                                                           OUTSUB.57    
      OFF=0.                                                               OUTSUB.58    
      IF (IOUT.EQ.12) OFF=-DFAC                                            OUTSUB.59    
      DO 20 IHEM=1,NHEM                                                    OUTSUB.60    
      DO 20 J=1,JG                                                         OUTSUB.61    
      IF (IOUT.EQ.2) OFF=-2.*SI(J)*(3-2*IHEM)*DFAC                         OUTSUB.62    
      IF (IOUT.EQ.5.OR.IOUT.EQ.6) DFACT=DFAC/CS(J)                         OUTSUB.63    
      DO 20 L=1,NLOUT                                                      OUTSUB.64    
      IF (IOUT.EQ.7) OFF=-273.15                                           OUTSUB.65    
      DO 20 I=1,MG                                                         OUTSUB.66    
   20 GPV(I,IHEM,L,J)=GPV(I,IHEM,L,J)*DFACT+OFF                            OUTSUB.67    
C                                                                          OUTSUB.68    
C     ----------------------------------------------------------------     OUTSUB.69    
C     Loop over levels.                                                    OUTSUB.70    
C     Set switches for printing, plotting and dumping.                     OUTSUB.71    
C                                                                          OUTSUB.72    
      DO 60 L=1,NLOUT                                                      OUTSUB.73    
C                                                                          OUTSUB.74    
      LPRINT=LOUTP.AND.LOUTGR                                              OUTSUB.75    
      LPLOT =LOUTF.AND.LOUTPL                                              OUTSUB.76    
      LDUMP =LOUTA.AND.LOUTPL                                              OUTSUB.77    
      IF (NLOUT.GT.1) THEN                                                 OUTSUB.78    
         LPRINT=LPRINT.AND.LGPO(L)                                         OUTSUB.79    
         LPLOT =LPLOT .AND.LGFO(L)                                         OUTSUB.80    
         LDUMP =LDUMP .AND.LGFO(L)                                         OUTSUB.81    
      ENDIF                                                                OUTSUB.82    
      LXY=LPRINT.OR.LPLOT.OR.LDUMP                                         OUTSUB.83    
      IF (.NOT.(LXY.OR.LZ)) GOTO 60                                        OUTSUB.84    
C                                                                          OUTSUB.85    
C     Calculate zonal average and set up 2-D array at current level.       OUTSUB.86    
C     Remove zonal average if required.                                    OUTSUB.87    
C                                                                          OUTSUB.88    
      DO 50 IHEM=1,NHEM                                                    OUTSUB.89    
      DO 50 J=1,JG                                                         OUTSUB.90    
      JJ=(2-IHEM)*J + (IHEM-1)*(JGGP+1-J)                                  OUTSUB.91    
      IF (LZ.OR.(LXY.AND.LSGEDY)) THEN                                     OUTSUB.92    
         JZ=JJ-(IHEM-1)                                                    OUTSUB.93    
         GVZ(JZ,L)=SSUM(MG,GPV(1,IHEM,L,J),1)*RMG                          OUTSUB.94    
      ENDIF                                                                OUTSUB.95    
      IF (.NOT.LXY) GOTO 50                                                OUTSUB.96    
      IF (LSGEDY) THEN                                                     OUTSUB.97    
         DO 30 I=1,MG                                                      OUTSUB.98    
   30    GV(I,JJ)=GPV(I,IHEM,L,J)-GVZ(JZ,L)                                OUTSUB.99    
      ELSE                                                                 OUTSUB.100   
         DO 40 I=1,MG                                                      OUTSUB.101   
   40    GV(I,JJ)=GPV(I,IHEM,L,J)                                          OUTSUB.102   
      ENDIF                                                                OUTSUB.103   
   50 CONTINUE                                                             OUTSUB.104   
      IF (.NOT.LXY) GOTO 60                                                OUTSUB.105   
C                                                                          OUTSUB.106   
C     Set up character title to pass to output routines.                   OUTSUB.107   
C                                                                          OUTSUB.108   
      IF (LSGEDY) THEN                                                     OUTSUB.109   
         WRITE(NAMC,'(''EDDY '',A,A)') NAME(1:35),NAME(41:50)              OUTSUB.110   
      ELSE                                                                 OUTSUB.111   
         NAMC(1:50)=NAME(1:50)                                             OUTSUB.112   
      ENDIF                                                                OUTSUB.113   
      IF (NLOUT.GT.1) THEN                                                 OUTSUB.114   
         IF (LINTP2) THEN                                                  OUTSUB.115   
            WRITE(NAMC(26:40),'('' PRESS='',F6.1,2X)') PLOUT(L)            OUTSUB.116   
         ELSE                                                              OUTSUB.117   
            WRITE(NAMC(26:40),'('' SIGMA='',F6.4,2X)') SIGMA(L)            OUTSUB.118   
         ENDIF                                                             OUTSUB.119   
      ENDIF                                                                OUTSUB.120   
C                                                                          OUTSUB.121   
C     Set switches for orographic mask.                                    OUTSUB.122   
C                                                                          OUTSUB.123   
      PMSKL=0.                                                             OUTSUB.124   
      IMSK=0                                                               OUTSUB.125   
      IF (LMSK2.AND.(LPLOT.OR.LDUMP).AND.(NLOUT.GT.1)) THEN                OUTSUB.126   
         PMSKL=PPR(L)*PMFAC                                                OUTSUB.127   
         IF (PMSKL.GT.P2MIN) IMSK=NINT(PMSKL)                              OUTSUB.128   
      ENDIF                                                                OUTSUB.129   
C                                                                          OUTSUB.130   
C     Set contour interval.                                                OUTSUB.131   
C                                                                          OUTSUB.132   
      FINC=CINC                                                            OUTSUB.133   
      IF (IOUT.EQ.4.AND.L.EQ.NL) FINC=.5*FINC                              OUTSUB.134   
C                                                                          OUTSUB.135   
C     Prepare 2-D array for output.  Set up factors and contour levels.    OUTSUB.136   
C     Then call required routines.                                         OUTSUB.137   
C                                                                          OUTSUB.138   
      CALL GVPREP(GV,AFAC,FINC,CL,NCNT,GNORM,GINC,ICNT,GMIN,GMAX,IFAIL)    OUTSUB.139   
      IF (IFAIL.NE.0) CALL GFAIL(IFAIL,LPRINT,LPLOT,LDUMP,NAMC,ICNT)       OUTSUB.140   
C                                                                          OUTSUB.141   
      IF (LPRINT) CALL GPRINT(GV,NAMC,GMIN,GMAX,GNORM,NPC2)                OUTSUB.142   
C                                                                          OUTSUB.143   
      IF (LDUMP) CALL WTFUTF(GV,MGP,JGGP,IPTYP,ICSTYL,0,0,1,IMSK           OUTSUB.144   
     :                      ,GMIN,GMAX,GINC,DAY,NAMC,50,NPCA,IFAIL)        OUTSUB.145   
C                                                                          OUTSUB.146   
      IF (.NOT.LPLOT) GOTO 60                                              OUTSUB.147   
C                                                                          OUTSUB.153   
   60 CONTINUE                                                             OUTSUB.154   
C                                                                          OUTSUB.155   
C     ----------------------------------------------------------------     OUTSUB.156   
C     End of loop over levels.                                             OUTSUB.157   
C                                                                          OUTSUB.158   
C     Output zonal average of field.                                       OUTSUB.159   
C                                                                          OUTSUB.160   
      IF (LZ) THEN                                                         OUTSUB.161   
         LPRINT=LOUTP.AND.LOUTGR.AND.LSGGRZ                                OUTSUB.162   
         LPLOT =LOUTF.AND.LOUTPL.AND.LSGPLZ.AND.(NLOUT.EQ.NL)              OUTSUB.163   
         LDUMP =LOUTA.AND.LOUTPL.AND.LSGPLZ.AND.(NLOUT.EQ.NL)              OUTSUB.164   
         WRITE(NAMC,'(A,5X,A,10X)') NAME(1:25),NAME(41:50)                 OUTSUB.165   
         ZFAC=AFAC                                                         OUTSUB.166   
         IF (IOUT.EQ.6) ZFAC=.1*AFAC                                       OUTSUB.167   
         IZDIM=1                                                           OUTSUB.168   
         IF (LINTP2) IZDIM=2                                               OUTSUB.169   
         IF (NLOUT.EQ.1) IZDIM=0                                           OUTSUB.170   
         CALL XSECT(GVZ,NLOUT,NAMC,NPC2,ZFAC,CINC,LPRINT,LPLOT,LDUMP       OUTSUB.171   
     :             ,.TRUE.,0,IZDIM,0)                                      SUNMOD.66    
      ENDIF                                                                OUTSUB.173   
C                                                                          OUTSUB.174   
      RETURN                                                               OUTSUB.175   
      END                                                                  OUTSUB.176   
C     ****************************************************************     OUTSUB.177   
*DECK OPERTEL                                                              OPERTEL.1     
      SUBROUTINE OPERTEL                                                   OPERTEL.2     
C                                                                          OPERTEL.3     
C     Print, plot and dump fields on isentropic surfaces.                  OPERTEL.4     
C     Include phase-shifted wind vectors on plots.                         OPERTEL.5     
C     NB.  Uses common SPECTR as workspace for GPV array.                  OPERTEL.6     
C                                                                          OPERTEL.7     
*CALL PARAM1                                                               OPERTEL.8     
*CALL PARAM2                                                               OPERTEL.9     
      PARAMETER(NCNT=50)                                                   OPERTEL.10    
C                                                                          OPERTEL.11    
*CALL BATS                                                                 OPERTEL.12    
*CALL BLANK                                                                OPERTEL.13    
*CALL COMIOC                                                               OPERTEL.14    
*CALL COMMSK                                                               OPERTEL.15    
*CALL DUM                                                                  OPERTEL.16    
*CALL LEGAU                                                                OPERTEL.18    
*CALL OUTCON                                                               OPERTEL.19    
*CALL SPECTR                                                               OPERTEL.20    
      REAL GPV(MGPP,NHEM,NTHSF,JG,NTH)                                     OPERTEL.21    
      EQUIVALENCE (GPV(1,1,1,1,1),Z(1))                                    OPERTEL.22    
      REAL GV(MGP,JGGP),GX(MGP,JGGP),GY(MGP,JGGP)                          OPERTEL.23    
      EQUIVALENCE (GV,GVE(1,1)),(GX,GVE(1,2)),(GY,GVE(1,3))                OPERTEL.24    
      REAL CL(NCNT),DFAC(NTH)                                              OPERTEL.25    
      LOGICAL LPRINT,LPLOT,LDUMP,LVEC                                      OPERTEL.26    
      CHARACTER NAMES(NTH)*50,NAMC*50                                      OPERTEL.27    
      SAVE NAMES                                                           OPERTEL.28    
C                                                                          OPERTEL.29    
      DATA NAMES/                                                          OPERTEL.30    
     1 'U-CPHASE                  THETA=         M/S      '                OPERTEL.31    
     2,'V                         THETA=         M/S      '                OPERTEL.32    
     3,'ERTEL POT VORT            THETA=         PVU      '                OPERTEL.33    
     4,'PRESSURE                  THETA=         MB       '/               OPERTEL.34    
C                                                                          OPERTEL.35    
 6000 FORMAT(' PROCESSING ISENTROPIC FIELDS AT DAY',F10.2,' KOUNT=',I10)   OPERTEL.36    
 6010 FORMAT(/' DAY',F10.2,'  NUMBER OF TIME STEPS COMPLETED =',I10)       OPERTEL.37    
C                                                                          OPERTEL.38    
C     Print headers.                                                       OPERTEL.39    
C                                                                          OPERTEL.40    
      IF (NPC6.NE.6) THEN                                                  OPERTEL.41    
         IF (LOUTP) WRITE(NPC6,'(///)')                                    OPERTEL.42    
         WRITE(NPC6,6000) DAY,KOUNT                                        OPERTEL.43    
      ENDIF                                                                OPERTEL.44    
      WRITE(6,6000) DAY,KOUNT                                              OPERTEL.45    
C                                                                          OPERTEL.46    
C     Dimensionalising factors, switches.                                  OPERTEL.47    
C                                                                          OPERTEL.48    
      DFAC(1)=CV                                                           OPERTEL.49    
      DFAC(2)=CV                                                           OPERTEL.50    
      DFAC(3)=1.E6*CERT                                                    OPERTEL.51    
      DFAC(4)=P0/100.                                                      OPERTEL.52    
C                                                                          OPERTEL.53    
      IPTYP=IZGTYP                                                         OPERTEL.54    
      ICSTYL=0                                                             OPERTEL.55    
      NPLT=1                                                               OPERTEL.56    
      IMSK=0                                                               OPERTEL.57    
C                                                                          OPERTEL.58    
C     Read data as JG records from scratch file.                           OPERTEL.59    
C                                                                          OPERTEL.60    
      REWIND NCTHG                                                         OPERTEL.61    
      DO 10 J=1,JG                                                         OPERTEL.62    
      READ(NCTHG) ((((GPV(I,IHEM,L,J,K),I=1,MGPP),IHEM=1,NHEM)             OPERTEL.63    
     :                              ,L=1,NTHSF),K=1,4)                     OPERTEL.64    
   10 CONTINUE                                                             OPERTEL.65    
      REWIND NCTHG                                                         OPERTEL.66    
C                                                                          OPERTEL.67    
C     Dimensionalise fields, removing eastward phase speed.                OPERTEL.68    
C                                                                          OPERTEL.69    
      DO 20 IHEM=1,NHEM                                                    OPERTEL.70    
      DO 20 J=1,JG                                                         OPERTEL.71    
      OFF=-CPHASE*CS(J)                                                    OPERTEL.72    
      CUTOFF=.99/CS(J)+OFF                                                 OPERTEL.73    
      DO 20 L=1,NTHSF                                                      OPERTEL.74    
      DO 20 I=1,MG                                                         OPERTEL.75    
      UTEMP=GPV(I,IHEM,L,J,1)/CS(J)+OFF                                    OPERTEL.76    
      IF (UTEMP.GT.CUTOFF) THEN                                            SUNMOD.78    
        GPV(I,IHEM,L,J,1)=0.0                                              SUNMOD.79    
       ELSE                                                                SUNMOD.80    
        GPV(I,IHEM,L,J,1)=UTEMP*DFAC(1)                                    SUNMOD.81    
      ENDIF                                                                SUNMOD.82    
      GPV(I,IHEM,L,J,2)=GPV(I,IHEM,L,J,2)*DFAC(2)/CS(J)                    OPERTEL.78    
      GPV(I,IHEM,L,J,3)=GPV(I,IHEM,L,J,3)*DFAC(3)                          OPERTEL.79    
   20 GPV(I,IHEM,L,J,4)=GPV(I,IHEM,L,J,4)*DFAC(4)                          OPERTEL.80    
C                                                                          OPERTEL.81    
C     ----------------------------------------------------------------     OPERTEL.82    
C     Loop over fields.  First set switches.                               OPERTEL.83    
C                                                                          OPERTEL.84    
      DO 100 IOUT=1,NTH                                                    OPERTEL.85    
C                                                                          OPERTEL.86    
      LPRINT=LOUTP.AND.LTHGR(IOUT)                                         OPERTEL.87    
      LPLOT =LOUTF.AND.LTHPL(IOUT)                                         OPERTEL.88    
      LDUMP =LOUTA.AND.LTHPL(IOUT)                                         OPERTEL.89    
      LVEC=(LPLOT.OR.LDUMP).AND.IOUT.GT.2                                  OPERTEL.90    
      IF (.NOT.(LPRINT.OR.LPLOT.OR.LDUMP)) GOTO 100                        OPERTEL.91    
      IF (LOUTP) WRITE(NPC6,6010) DAY,KOUNT                                OPERTEL.92    
C                                                                          OPERTEL.93    
C     Loop over isentropic levels for each field.                          OPERTEL.94    
C                                                                          OPERTEL.95    
      DO 60 L=1,NTHSF                                                      OPERTEL.96    
      FINC=THINC(IOUT)                                                     OPERTEL.97    
      IF (IOUT.EQ.3.AND.L.LE.2) FINC=2.*FINC                               OPERTEL.98    
      IF (IOUT.EQ.3.AND.L.GE.4) FINC=.5*FINC                               OPERTEL.99    
      DO 30 N=1,4                                                          OPERTEL.100   
   30 WRITE(NAMES(N)(33:36),'(F4.0)') THSURD(L)                            OPERTEL.101   
C                                                                          OPERTEL.102   
C     Calculate zonal average and set up 2-D array at current level.       OPERTEL.103   
C                                                                          OPERTEL.104   
      DO 40 IHEM=1,NHEM                                                    OPERTEL.105   
      DO 40 J=1,JG                                                         OPERTEL.106   
      JJ=(2-IHEM)*J + (IHEM-1)*(JGGP+1-J)                                  OPERTEL.107   
      JZ=JJ-(IHEM-1)                                                       OPERTEL.108   
      GVZ(JZ,L)=SSUM(MG,GPV(1,IHEM,L,J,IOUT),1)*RMG                        OPERTEL.109   
      DO 40 I=1,MG                                                         OPERTEL.110   
      GV(I,JJ)=GPV(I,IHEM,L,J,IOUT)                                        OPERTEL.111   
   40 CONTINUE                                                             OPERTEL.112   
C                                                                          OPERTEL.113   
C     Copy wind components into vector arrays if wind vectors plotted.     OPERTEL.114   
C                                                                          OPERTEL.115   
      IF (LVEC) THEN                                                       OPERTEL.116   
         DO 50 IHEM=1,NHEM                                                 OPERTEL.117   
         DO 50 J=1,JG                                                      OPERTEL.118   
         JJ=(2-IHEM)*J + (IHEM-1)*(JGGP+1-J)                               OPERTEL.119   
         DO 50 I=1,MG                                                      OPERTEL.120   
         GX(I,JJ)=GPV(I,IHEM,L,J,1)                                        OPERTEL.121   
         GY(I,JJ)=GPV(I,IHEM,L,J,2)                                        OPERTEL.122   
   50    CONTINUE                                                          OPERTEL.123   
         CALL GVPREP(GX,0.,0.,CL,1,UNORM,UINC,ICNT,UMIN,UMAX,IFAIL)        OPERTEL.124   
         CALL GVPREP(GY,0.,0.,CL,1,VNORM,VINC,ICNT,VMIN,VMAX,IFAIL)        OPERTEL.125   
      ENDIF                                                                OPERTEL.126   
C                                                                          OPERTEL.127   
C     Prepare 2-D array for output.  Set up factors and contour levels.    OPERTEL.128   
C     Then call required routines.                                         OPERTEL.129   
C                                                                          OPERTEL.130   
      CALL GVPREP(GV,THFAC(IOUT),FINC,CL,NCNT,GNORM,GINC,ICNT              OPERTEL.131   
     :           ,GMIN,GMAX,IFAIL)                                         OPERTEL.132   
      IF (IFAIL.NE.0) CALL GFAIL(IFAIL,LPRINT,LPLOT,LDUMP                  OPERTEL.133   
     :                          ,NAMES(IOUT)(1:40),ICNT)                   OPERTEL.134   
C                                                                          OPERTEL.135   
      IF (LPRINT) CALL GPRINT(GV,NAMES(IOUT),GMIN,GMAX,GNORM,NPC6)         OPERTEL.136   
C                                                                          OPERTEL.137   
      IF (LDUMP) THEN                                                      OPERTEL.138   
         CALL WTFUTF(GV,MGP,JGGP,IPTYP,ICSTYL,0,3,1,IMSK                   OPERTEL.139   
     :              ,GMIN,GMAX,GINC,DAY,NAMES(IOUT),50,NPCA,IFAIL)         OPERTEL.140   
         IF (LVEC) THEN                                                    OPERTEL.141   
            CALL WTFUTF(GX,MGP,JGGP,IPTYP,IRSKIP,1,3,0,IMSK                OPERTEL.142   
     :                 ,UMIN,UMAX,ARSTD,DAY,NAMES(1),50,NPCA,IFAIL)        OPERTEL.143   
            CALL WTFUTF(GY,MGP,JGGP,IPTYP,IRSKIP,2,3,0,IMSK                OPERTEL.144   
     :                 ,VMIN,VMAX,ARSTD,DAY,NAMES(2),50,NPCA,IFAIL)        OPERTEL.145   
         ENDIF                                                             OPERTEL.146   
      ENDIF                                                                OPERTEL.147   
C                                                                          OPERTEL.148   
      IF (.NOT.LPLOT) GOTO 60                                              OPERTEL.149   
C                                                                          OPERTEL.157   
   60 CONTINUE                                                             OPERTEL.158   
C                                                                          OPERTEL.159   
C     Print zonal average of field.                                        OPERTEL.160   
C                                                                          OPERTEL.161   
      IF (LPRINT) THEN                                                     OPERTEL.162   
         ZFAC=THFAC(IOUT)                                                  OPERTEL.163   
         IF (IOUT.EQ.2) ZFAC=.1*ZFAC                                       OPERTEL.164   
         WRITE(NAMC,'(A,5X,A,10X)') NAMES(IOUT)(1:25),NAMES(IOUT)(41:50)   OPERTEL.165   
         CALL XSECT(GVZ,NTHSF,NAMC,NPC6,ZFAC,0.,LPRINT                     OPERTEL.166   
     :             ,.FALSE.,.FALSE.,.TRUE.,0,3,0)                          SUNMOD.67    
      ENDIF                                                                OPERTEL.168   
C                                                                          OPERTEL.169   
  100 CONTINUE                                                             OPERTEL.170   
C                                                                          OPERTEL.171   
C     ----------------------------------------------------------------     OPERTEL.172   
C                                                                          OPERTEL.173   
      RETURN                                                               OPERTEL.174   
      END                                                                  OPERTEL.175   
C     ****************************************************************     OPERTEL.176   
*DECK GVPREP                                                               GVPREP.1     
      SUBROUTINE GVPREP(GV,AFAC,CINC,CL,NCNT,GNORM,GINC,ICNT               GVPREP.2     
     :                 ,GMIN,GMAX,IFAIL)                                   GVPREP.3     
C                                                                          GVPREP.4     
C     Prepare a 2D array for printing by GPRINT and plotting by            GVPREP.5     
C     GPOLAR, GLATLON etc. Method:                                         GVPREP.6     
C        a) Interpolate or extrapolate to equator.                         GVPREP.7     
C        b) Copy GV(1,J) into GV(MGP,J) for plotting routines.             GVPREP.8     
C        c) Call GPREP with AFAC and contour interval to set up GNORM      GVPREP.9     
C           for printing and contour levels CL(NCNT) for plotting.         GVPREP.10    
C     IFAIL values are as follows:                                         GVPREP.11    
C        0    :    successful completion.                                  GVPREP.12    
C        1    :    all field values equal : no contours.                   GVPREP.13    
C        2    :    too many contours required : only NCNT set up.          GVPREP.14    
*CALL PARAM1                                                               GVPREP.15    
*CALL PARAM2                                                               GVPREP.16    
*CALL LEGAU                                                                GVPREP.17    
      REAL GV(MGP,JGGP),CL(NCNT)                                           GVPREP.18    
C                                                                          GVPREP.19    
      IFAIL=0                                                              GVPREP.20    
C                                                                          GVPREP.21    
C     Interpolation / extrapolation to equator.                            GVPREP.22    
C     Hemispheric: quadratic extrapolation with zero gradient              GVPREP.23    
C     on equator (see routine INILAT).                                     GVPREP.24    
C     Global: linear interpolation.                                        GVPREP.25    
C                                                                          GVPREP.26    
      IF (NHEM.EQ.1) THEN                                                  GVPREP.27    
         DO 10 I=1,MG                                                      GVPREP.28    
   10    GV(I,JGP)=(EXE2*GV(I,JG)-EXE1*GV(I,JGM))*EXE3                     GVPREP.29    
      ELSE                                                                 GVPREP.30    
         DO 20 I=1,MG                                                      GVPREP.31    
   20    GV(I,JGP)=.5*(GV(I,JG)+GV(I,JG+2))                                GVPREP.32    
      ENDIF                                                                GVPREP.33    
C                                                                          GVPREP.34    
C     Copy first longitude into MGP position for plotting.                 GVPREP.35    
C                                                                          GVPREP.36    
      DO 30 J=1,JGGP                                                       GVPREP.37    
   30 GV(MGP,J)=GV(1,J)                                                    GVPREP.38    
C                                                                          GVPREP.39    
      CALL GPREP(GV,IDH,AFAC,CINC,CL,NCNT,GNORM,GINC,ICNT                  GVPREP.40    
     :          ,GMIN,GMAX,IFAIL)                                          GVPREP.41    
C                                                                          GVPREP.42    
      RETURN                                                               GVPREP.43    
      END                                                                  GVPREP.44    
C     ****************************************************************     GVPREP.45    
*DECK GPREP                                                                GPREP.1     
      SUBROUTINE GPREP(G,JXY,AFAC,CINC,CL,NCNT,GNORM,GINC,ICNT             GPREP.2     
     :                ,GMIN,GMAX,IFAIL)                                    GPREP.3     
C                                                                          GPREP.4     
C     Prepare an array for printing and plotting.                          GPREP.5     
C     Use AFAC to set up GNORM multiplying factor for printing.            GPREP.6     
C     Use CINC to set up contour levels CL(NCNT) for plotting.             GPREP.7     
C     NB.  Field is NOT scaled or overwritten. Contour levels are          GPREP.8     
C     converted to same dimensions as field.                               GPREP.9     
C     Options are:                                                         GPREP.10    
C        a) CINC.GT.0        Use input value of AFAC as scaling            GPREP.11    
C                            factor for printing.                          GPREP.12    
C                            Use input value of CINC as contour            GPREP.13    
C                            interval for plotting.                        GPREP.14    
C        b) CINC.LT.-1       For printing normalise max. abs. value        GPREP.15    
C                            of field to 1000.                             GPREP.16    
C                            For plotting normalise range of field         GPREP.17    
C                            to 1000. Contour interval is -CINC in         GPREP.18    
C                            normalised units.                             GPREP.19    
C        c) -1.LE.CINC.LT.0  For printing normalise max. abs. value        GPREP.20    
C                            of field to lie between 0.1 and 1 by          GPREP.21    
C                            removing powers of 10 only.                   GPREP.22    
C                            For plotting normalise range of field         GPREP.23    
C                            to lie between 0.1 and 1 by removing          GPREP.24    
C                            powers of 10 only. Contour interval is        GPREP.25    
C                            -CINC in normalised units.                    GPREP.26    
C     IFAIL values are as follows:                                         GPREP.27    
C        -3    :    input print factor & contour interval both zero.       GPREP.28    
C        -2    :    input print factor zero.                               GPREP.29    
C        -1    :    input contour interval zero.                           GPREP.30    
C         0    :    successful completion.                                 GPREP.31    
C         1    :    field has zero range :  no contours set up.            GPREP.32    
C         2    :    too many contours required : only NCNT set up.         GPREP.33    
C                                                                          GPREP.34    
      REAL G(JXY),CL(NCNT)                                                 GPREP.35    
C                                                                          GPREP.36    
      IFAIL=0                                                              GPREP.37    
C                                                                          GPREP.38    
C     Find minimum and maximum values.                                     GPREP.39    
C                                                                          GPREP.40    
      IM=ISMAX(JXY,G,1)                                                    GPREP.41    
      GMAX=G(IM)                                                           GPREP.42    
      IM=ISMIN(JXY,G,1)                                                    GPREP.43    
      GMIN=G(IM)                                                           GPREP.44    
C                                                                          GPREP.45    
C     Check input arguments.                                               GPREP.46    
C                                                                          GPREP.47    
      IF (AFAC.EQ.0..AND.CINC.EQ.0.) THEN                                  GPREP.48    
         GNORM=0.                                                          GPREP.49    
         GINC=0.                                                           GPREP.50    
         ICNT=0                                                            GPREP.51    
         IFAIL=-3                                                          GPREP.52    
         RETURN                                                            GPREP.53    
      ELSE IF (AFAC.EQ.0.) THEN                                            GPREP.54    
         GNORM=0.                                                          GPREP.55    
         IFAIL=-2                                                          GPREP.56    
      ENDIF                                                                GPREP.57    
C                                                                          GPREP.58    
C     Check for zero range.                                                GPREP.59    
C                                                                          GPREP.60    
      ZAMAX=MAX(ABS(GMAX),ABS(GMIN))                                       SUNMOD.95    
      ZRANGE=GMAX-GMIN                                                     GPREP.62    
      IF (ZRANGE.LE.ZAMAX*1.E-10) THEN                                     GPREP.63    
         IF (AFAC.NE.0.) GNORM=1./AFAC                                     GPREP.64    
         GINC=0.                                                           GPREP.65    
         ICNT=0                                                            GPREP.66    
         IFAIL=1                                                           GPREP.67    
         RETURN                                                            GPREP.68    
      ENDIF                                                                GPREP.69    
C                                                                          GPREP.70    
C     Set up factor for printed output and contour levels for plotting.    GPREP.71    
C                                                                          GPREP.72    
      IF (CINC.GT.0) THEN                                                  GPREP.73    
         IF (AFAC.NE.0.) GNORM=1./AFAC                                     GPREP.74    
         GINC=CINC                                                         GPREP.75    
      ELSE IF (CINC.LT.-1.) THEN                                           GPREP.76    
         IF (AFAC.NE.0.) GNORM=1000./ZAMAX                                 GPREP.77    
         GINC=-ZRANGE*CINC/1000.                                           GPREP.78    
      ELSE IF (CINC.LT.0.) THEN                                            GPREP.79    
         IF (AFAC.NE.0.) THEN                                              GPREP.80    
            IEXP=LOG10(ZAMAX)*.99999                                       SUNMOD.93    
            IF (ZAMAX.GT.1.) IEXP=IEXP+1                                   GPREP.82    
            ZA10=10.**IEXP                                                 GPREP.83    
            GNORM=1000./ZA10                                               GPREP.84    
         ENDIF                                                             GPREP.85    
         IEXP=LOG10(ZRANGE)*.99999                                         SUNMOD.94    
         IF (ZRANGE.GT.1.) IEXP=IEXP+1                                     GPREP.87    
         ZA10=10.**IEXP                                                    GPREP.88    
         ZFRACT=ZRANGE/ZA10                                                GPREP.89    
         IF (ZFRACT.GT.0.5) THEN                                           GPREP.90    
            GINC=-ZA10*CINC                                                GPREP.91    
         ELSE IF (ZFRACT.GT.0.2) THEN                                      GPREP.92    
            GINC=-ZA10*CINC*0.5                                            GPREP.93    
         ELSE                                                              GPREP.94    
            GINC=-ZA10*CINC*0.2                                            GPREP.95    
         ENDIF                                                             GPREP.96    
      ELSE                                                                 GPREP.97    
         IF (AFAC.NE.0.) GNORM=1./AFAC                                     GPREP.98    
         GINC=0.                                                           GPREP.99    
         ICNT=0                                                            GPREP.100   
         IFAIL=-1                                                          GPREP.101   
         RETURN                                                            GPREP.102   
      ENDIF                                                                GPREP.103   
C                                                                          GPREP.104   
C     Calculate contour levels.                                            GPREP.105   
C                                                                          GPREP.106   
      ILO=INT(GMIN/GINC)                                                   GPREP.107   
      IF (GMIN.GE.0.) ILO=ILO+1                                            GPREP.108   
      CLV=FLOAT(ILO-1)*GINC                                                GPREP.109   
      I=0                                                                  GPREP.110   
   10 CLV=CLV+GINC                                                         GPREP.111   
      I=I+1                                                                GPREP.112   
      IF (I.GT.NCNT) GOTO 20                                               GPREP.113   
      IF (CLV.GT.GMAX) GOTO 30                                             GPREP.114   
      CL(I)=CLV                                                            GPREP.115   
      GOTO 10                                                              GPREP.116   
   20 IFAIL=2                                                              GPREP.117   
   30 ICNT=I-1                                                             GPREP.118   
C                                                                          GPREP.119   
      RETURN                                                               GPREP.120   
      END                                                                  GPREP.121   
C     ****************************************************************     GPREP.122   
*DECK GFAIL                                                                GFAIL.1     
      SUBROUTINE GFAIL(IFAIL,LPRINT,LPLOT,LDUMP,NAME,ICNT)                 GFAIL.2     
C                                                                          GFAIL.3     
C     Check failure code from GPREP, printing warnings and                 GFAIL.4     
C     modifying logical switches as necessary.                             GFAIL.5     
C                                                                          GFAIL.6     
      LOGICAL LPRINT,LPLOT,LDUMP                                           GFAIL.7     
      CHARACTER NAME*(*)                                                   GFAIL.8     
C                                                                          GFAIL.9     
 6900 FORMAT(/' ***GFAIL: ',A,'     NOT PRINTED, PLOTTED OR DUMPED:'       GFAIL.10    
     :       ,' PRINT FACTOR AND CONTOUR INTERVAL BOTH ZERO')              GFAIL.11    
 6910 FORMAT(/' ***GFAIL: ',A,'     NOT PRINTED:'                          GFAIL.12    
     :       ,' PRINT FACTOR IS ZERO')                                     GFAIL.13    
 6920 FORMAT(/' ***GFAIL: ',A,'     NOT PLOTTED OR DUMPED:'                GFAIL.14    
     :       ,' CONTOUR INTERVAL IS ZERO')                                 GFAIL.15    
 6930 FORMAT(/' ***GFAIL: ',A,'     : FIELD HAS ZERO RANGE')               GFAIL.16    
 6940 FORMAT(/' ***GFAIL: ',A,' :   ONLY',I3,' CONTOURS PLOTTED')          GFAIL.17    
C                                                                          GFAIL.18    
      IF (IFAIL.EQ.-3) THEN                                                GFAIL.19    
         WRITE(6,6900) NAME                                                GFAIL.20    
         LPRINT=.FALSE.                                                    SUNMOD.68    
         LPLOT=.FALSE.                                                     SUNMOD.69    
         LDUMP=.FALSE.                                                     SUNMOD.70    
      ELSE IF (IFAIL.EQ.-2) THEN                                           GFAIL.24    
         IF (LPRINT) WRITE(6,6910) NAME                                    GFAIL.25    
         LPRINT=.FALSE.                                                    SUNMOD.71    
      ELSE IF (IFAIL.EQ.-1) THEN                                           GFAIL.27    
         IF (LPLOT.OR.LDUMP) WRITE(6,6920) NAME                            GFAIL.28    
         LPLOT=.FALSE.                                                     SUNMOD.72    
         LDUMP=.FALSE.                                                     SUNMOD.73    
      ELSE IF (IFAIL.EQ.1) THEN                                            GFAIL.31    
         WRITE(6,6930) NAME                                                GFAIL.32    
      ELSE IF (IFAIL.EQ.2) THEN                                            GFAIL.33    
         IF (LPLOT.OR.LDUMP) WRITE(6,6940) NAME,ICNT                       GFAIL.34    
      ENDIF                                                                GFAIL.35    
C                                                                          GFAIL.36    
      RETURN                                                               GFAIL.37    
      END                                                                  GFAIL.38    
C     ****************************************************************     GFAIL.39    
*DECK GPRINT                                                               GPRINT.1     
      SUBROUTINE GPRINT(GV,NAME,GMIN,GMAX,GNORM,NPC)                       GPRINT.2     
C                                                                          GPRINT.3     
C     To print an integer map of a single level (global) field.            GPRINT.4     
C     Hemispheres printed separately with longitude increasing downward.   GPRINT.5     
C     N Hem has equator on left, pole on right; S Hem has pole on left,    GPRINT.6     
C     equator on right, same as right-handed sections from XSECT.          GPRINT.7     
C     Input:                                                               GPRINT.8     
C        GV(MGP,JGGP)   Global field, north pole to equator (NHEM=1)       GPRINT.9     
C                       or south pole (NHEM=2). Extra latitude JGP at      GPRINT.10    
C                       equator. First longitude repeated in (MGP,J).      GPRINT.11    
C        NAME(char*50)  (1:40) name of field & type/value of level.        GPRINT.12    
C                       (41:50) Dimensional units of field.                GPRINT.13    
C        GMIN,GMAX      Min & max of field in dimensional units.           GPRINT.14    
C        GNORM          Normalising factor from GPREP to obtain field      GPRINT.15    
C                       values in range <1000.                             GPRINT.16    
C        NPC            Fortran channel for output.                        GPRINT.17    
C     All arguments unchanged on output.                                   GPRINT.18    
C                                                                          GPRINT.19    
*CALL PARAM1                                                               GPRINT.20    
*CALL PARAM2                                                               GPRINT.21    
*CALL OUTCON                                                               GPRINT.22    
      REAL GV(MGP,JGGP)                                                    GPRINT.23    
      CHARACTER NAME*50,HEMANN(2)*25                                       GPRINT.24    
      SAVE HEMANN                                                          GPRINT.25    
C                                                                          GPRINT.26    
      DATA HEMANN/'EQUATOR........NORTH POLE'                              GPRINT.27    
     :           ,'SOUTH POLE........EQUATOR'/                             GPRINT.28    
C                                                                          GPRINT.29    
 6000 FORMAT(/1X,A,1PE10.3,A)                                              GPRINT.30    
 6001 FORMAT(/1X,A,F10.1,A)                                                GPRINT.31    
 6002 FORMAT(/1X,A,F10.3,A)                                                GPRINT.32    
 6010 FORMAT(16X,'MIN  MAX  =',1P,2(2X,E10.3),A)                           GPRINT.33    
 6020 FORMAT(1X,A)                                                         GPRINT.34    
 6030 FORMAT(1X,32I4)                                                      GPRINT.35    
C                                                                          GPRINT.36    
      ZUNIT=1./GNORM                                                       GPRINT.37    
      IF (ZUNIT.GT.1000..OR.ZUNIT.LE..099) THEN                            GPRINT.38    
         WRITE(NPC,6000) NAME(1:40),ZUNIT,NAME(41:50)                      GPRINT.39    
      ELSE IF (ZUNIT.GE.10.) THEN                                          GPRINT.40    
         WRITE(NPC,6001) NAME(1:40),ZUNIT,NAME(41:50)                      GPRINT.41    
      ELSE                                                                 GPRINT.42    
         WRITE(NPC,6002) NAME(1:40),ZUNIT,NAME(41:50)                      GPRINT.43    
      ENDIF                                                                GPRINT.44    
      WRITE(NPC,6010) GMIN,GMAX,NAME(41:50)                                GPRINT.45    
C                                                                          GPRINT.46    
      NPOLE=1+(NLAT-1)*INLAT                                               GPRINT.47    
      WRITE(NPC,6020) HEMANN(1)                                            GPRINT.48    
      DO 10 I=INLONG,MG,INLONG                                             GPRINT.49    
   10 WRITE(NPC,6030) (NINT(GV(I,J)*GNORM),J=NPOLE,1,-INLAT)               GPRINT.50    
      IF (NHEM.EQ.2) THEN                                                  GPRINT.51    
         WRITE(NPC,6020) HEMANN(2)                                         GPRINT.52    
         DO 20 I=INLONG,MG,INLONG                                          GPRINT.53    
   20    WRITE(NPC,6030) (NINT(GV(I,J)*GNORM),J=JGGP,JG+2,-INLAT)          GPRINT.54    
      ENDIF                                                                GPRINT.55    
C                                                                          GPRINT.56    
      RETURN                                                               GPRINT.57    
      END                                                                  GPRINT.58    
C     ****************************************************************     GPRINT.59    
*DECK FLXPRC                                                               FLXPRC.1     
      SUBROUTINE FLXPRC                                                    FLXPRC.2     
C                                                                          FLXPRC.3     
C     Print, plot and dump zonal averages of dynamical quantities          FLXPRC.4     
C     from common ZONAV for one analysis time.                             FLXPRC.5     
C     For KOUNT<0 time averages are copied from TAV and output.            FLXPRC.6     
C     All fields are temporarily dimensionised for output.                 FLXPRC.7     
C                                                                          FLXPRC.8     
*CALL PARAM1                                                               FLXPRC.9     
*CALL PARAM2                                                               FLXPRC.10    
*CALL BATS                                                                 FLXPRC.11    
*CALL BLANK                                                                FLXPRC.12    
*CALL COMPRL                                                               FLXPRC.13    
*CALL OUTCON                                                               FLXPRC.14    
*CALL TAV                                                                  FLXPRC.15    
*CALL ZONAV                                                                FLXPRC.16    
      REAL DDZ(IGG,NXD),DDZT(IGG,NXD),DFAC(NXD)                            FLXPRC.17    
      EQUIVALENCE (DDZ(1,1),UBR(1,1)),(DDZT(1,1),UBT(1,1))                 FLXPRC.18    
      LOGICAL LPRINT,LPLOT,LDUMP,LNPLT,LARROW                              FLXPRC.19    
      CHARACTER NAME(NXD)*45                                               FLXPRC.20    
      SAVE NAME                                                            FLXPRC.21    
C                                                                          FLXPRC.22    
      DATA (NAME(J),J=1,15)/                                               FLXPRC.23    
     1 'ZONAL WIND                     M/S           '                     FLXPRC.24    
     2,'POTENTIAL TEMPERATURE-300K     KELVIN        '                     FLXPRC.25    
     3,'TEMPERATURE                    DEG C         '                     FLXPRC.26    
     4,'MEAN MERIDIONAL CIRCULATION    KG/S          '                     FLXPRC.27    
     5,'HORIZONTAL EDDY MOMENTUM FLUX  (M/S)2        '                     FLXPRC.28    
     6,'VERTICAL EDDY MOMENTUM FLUX    (M/S)(MB/HR)  '                     FLXPRC.29    
     7,'HORIZONTAL EDDY HEAT FLUX      K(M/S)        '                     FLXPRC.30    
     8,'VERTICAL EDDY HEAT FLUX        K(MB/HR)      '                     FLXPRC.31    
     9,'ZONAL KINETIC ENERGY           J/KG          '                     FLXPRC.32    
     :,'EDDY KINETIC ENERGY            J/KG          '                     FLXPRC.33    
     1,'NORTHWARD E-P FLUX             (M3)(RAD)     '                     FLXPRC.34    
     2,'UPWARD E-P FLUX                (M3)(PA)      '                     FLXPRC.35    
     3,'HORIZONTAL E-P FLUX DIVERGENCE M3            '                     FLXPRC.36    
     4,'VERTICAL E-P FLUX DIVERGENCE   M3            '                     FLXPRC.37    
     5,'TOTAL E-P FLUX DIVERGENCE      M3            '                     FLXPRC.38    
     :/                                                                    FLXPRC.39    
      DATA (NAME(J),J=16,NXD)/                                             FLXPRC.40    
     6 'STATIC STABILITY               S-2           '                     FLXPRC.41    
     7,'QY FOR VARYING NSQUARED        (S-1)(M-1)    '                     FLXPRC.42    
     8,'TOTAL PERMITTED WAVENUMBER                   '                     FLXPRC.43    
     9,'TEMPERATURE ANOMALY            DEG C         '                     FLXPRC.44    
     :,'MEAN VERTICAL MOTION           MB/HR         '                     FLXPRC.45    
     1,'VERTICAL MEAN HEAT FLUX        K(MB/HR)      '                     FLXPRC.46    
     2,'MEAN MERIDIONAL WIND           M/S           '                     FLXPRC.47    
     3,'HORIZONTAL MEAN HEAT FLUX      K(M/S)        '                     FLXPRC.48    
     4,'SPECIFIC HUMIDITY              G/KG          '                     FLXPRC.49    
     5,'RELATIVE HUMIDITY              PER CENT      '                     FLXPRC.50    
     6,'HORIZONTAL EDDY MOISTURE FLUX  (M/S)(G/KG)   '                     FLXPRC.51    
     7,'VERTICAL EDDY MOISTURE FLUX    (MB/HR)(G/KG) '                     FLXPRC.52    
     8,'TOTAL DIABATIC HEATING         K/DAY         '                     FLXPRC.53    
     :/                                                                    FLXPRC.54    
C                                                                          FLXPRC.55    
 6000 FORMAT(' PROCESSING DYNAMICS Z-SECTS  AT DAY',F10.2,' KOUNT=',I10)   FLXPRC.56    
 6010 FORMAT(' PROCESSING DYNAMICS Z-SECTS  FOR TIME AVERAGES')            FLXPRC.57    
C                                                                          FLXPRC.58    
C     Dimensionalising factors.                                            FLXPRC.59    
C                                                                          FLXPRC.60    
      DFAC(1)=CV                                                           FLXPRC.61    
      DFAC(2)=CT                                                           FLXPRC.62    
      DFAC(3)=CT                                                           FLXPRC.63    
      DFAC(4)=CV*P0*(PI2*RADEA/GA)                                         FLXPRC.64    
      DFAC(5)=CG                                                           FLXPRC.65    
      DFAC(6)=CV*CMBHR                                                     FLXPRC.66    
      DFAC(7)=CV*CT                                                        FLXPRC.67    
      DFAC(8)=CT*CMBHR                                                     FLXPRC.68    
      DFAC(9)=CG                                                           FLXPRC.69    
      DFAC(10)=CG                                                          FLXPRC.70    
      DFAC(11)=CEP                                                         FLXPRC.71    
      DFAC(12)=CEP*P0                                                      FLXPRC.72    
      DFAC(13)=CEP                                                         FLXPRC.73    
      DFAC(14)=CEP                                                         FLXPRC.74    
      DFAC(15)=CEP                                                         FLXPRC.75    
      DFAC(16)=GA*GA/(RD*CT)                                               FLXPRC.76    
      DFAC(17)=WW/RADEA                                                    FLXPRC.77    
      DFAC(18)=1.                                                          FLXPRC.78    
      DFAC(19)=CT                                                          FLXPRC.79    
      DFAC(20)=CMBHR                                                       FLXPRC.80    
      DFAC(21)=CT*CMBHR                                                    FLXPRC.81    
      DFAC(22)=CV                                                          FLXPRC.82    
      DFAC(23)=CV*CT                                                       FLXPRC.83    
      DFAC(24)=CQ                                                          FLXPRC.84    
      DFAC(25)=100.                                                        FLXPRC.85    
      DFAC(26)=CV*CQ                                                       FLXPRC.86    
      DFAC(27)=CQ*CMBHR                                                    FLXPRC.87    
      DFAC(28)=CTT                                                         FLXPRC.88    
C                                                                          FLXPRC.89    
      IZDIM=1                                                              FLXPRC.90    
      IF (LINTP3) IZDIM=2                                                  FLXPRC.91    
C                                                                          FLXPRC.92    
C     Print header.  Temporarily dimensionalise all fields.                FLXPRC.93    
C     For time averages, copy from common TAV into ZONAV.                  FLXPRC.94    
C                                                                          FLXPRC.95    
      IF (LOUTP.AND.NPC3.NE.6) WRITE(NPC3,'(///)')                         FLXPRC.96    
      IF (KOUNT.GE.0) THEN                                                 FLXPRC.97    
         IF (NPC3.NE.6) WRITE(NPC3,6000) DAY,KOUNT                         FLXPRC.98    
         WRITE(6,6000) DAY,KOUNT                                           FLXPRC.99    
         DO 10 IOUT=1,NXD                                                  FLXPRC.100   
         DO 10 I=1,IGG                                                     FLXPRC.101   
   10    DDZ(I,IOUT)=DDZ(I,IOUT)*DFAC(IOUT)                                FLXPRC.102   
      ELSE                                                                 FLXPRC.103   
         IF (NPC3.NE.6) WRITE(NPC3,6010)                                   FLXPRC.104   
         WRITE(6,6010)                                                     FLXPRC.105   
         DO 20 IOUT=1,NXD                                                  FLXPRC.106   
         DO 20 I=1,IGG                                                     FLXPRC.107   
   20    DDZ(I,IOUT)=DDZT(I,IOUT)*DFAC(IOUT)                               FLXPRC.108   
      ENDIF                                                                FLXPRC.109   
C                                                                          FLXPRC.110   
C     Main loop over fields.                                               FLXPRC.111   
C                                                                          FLXPRC.112   
      DO 30 IOUT=1,NXD                                                     FLXPRC.113   
      LPRINT=LOUTP.AND.LXDGR(IOUT)                                         FLXPRC.114   
      LPLOT =LOUTF.AND.LXDPL(IOUT)                                         FLXPRC.115   
      LDUMP =LOUTA.AND.LXDPL(IOUT)                                         FLXPRC.116   
      LARROW=IOUT.EQ.15.OR.IOUT.EQ.18                                      FLXPRC.117   
      IF (.NOT.(LPRINT.OR.LPLOT.OR.LDUMP)) GOTO 30                         FLXPRC.118   
      IF (IOUT.EQ.19.AND.DAMP.LE.0.) GOTO 30                               FLXPRC.119   
      LNPLT=.TRUE.                                                         SUNMOD.74    
      ICSTYL=0                                                             FLXPRC.121   
      IF (IOUT.EQ.2) LNPLT=.FALSE.                                         SUNMOD.75    
      IF (IOUT.EQ.2.OR.IOUT.EQ.3.OR.IOUT.EQ.15) ICSTYL=1                   FLXPRC.123   
      CALL XSECT(DDZ(1,IOUT),NL,NAME(IOUT),NPC3,XDFAC(IOUT),XDINC(IOUT)    FLXPRC.124   
     :          ,LPRINT,LPLOT,LDUMP,LNPLT,ICSTYL,IZDIM,IOUT)               FLXPRC.125   
      IF (LARROW) THEN                                                     FLXPRC.126   
         IF (LDUMP) THEN                                                   FLXPRC.128   
            CALL WTFUTF(EPFH,JGG,NL,11,1,1,2,0,0,0.,0.,XDFAC(11),DAY       FLXPRC.129   
     :                 ,NAME(11),45,NPCA,IFAIL)                            FLXPRC.130   
            CALL WTFUTF(EPFV,JGG,NL,11,1,2,2,0,0,0.,0.,XDFAC(11),DAY       FLXPRC.131   
     :                 ,NAME(12),45,NPCA,IFAIL)                            FLXPRC.132   
         ENDIF                                                             FLXPRC.133   
      ENDIF                                                                FLXPRC.134   
   30 CONTINUE                                                             FLXPRC.135   
C                                                                          FLXPRC.136   
C     Non-dimensionalise all fields in case needed later.                  FLXPRC.137   
C                                                                          FLXPRC.138   
      DO 40 IOUT=1,NXD                                                     FLXPRC.139   
      DO 40 I=1,IGG                                                        FLXPRC.140   
   40 DDZ(I,IOUT)=DDZ(I,IOUT)/DFAC(IOUT)                                   FLXPRC.141   
C                                                                          FLXPRC.142   
      RETURN                                                               FLXPRC.143   
      END                                                                  FLXPRC.144   
C     ****************************************************************     FLXPRC.145   
*DECK XSECT                                                                XSECT.1     
      SUBROUTINE XSECT(F,NLOUT,NAME,NPC,AFAC,CINC,LPRINT,LPLOT,LDUMP       XSECT.2     
     :                ,LNPLT,ICSTYL,IZDIM,IOUT)                            XSECT.3     
C                                                                          XSECT.4     
C     To print, plot and dump a zonal cross-section.                       XSECT.5     
C     Used for all zonally averaged fields.  No film or dump to UTF        XSECT.6     
C     (ie print only) if NLOUT not equal NL.                               XSECT.7     
C     Includes orographic mask field if required.                          XSECT.8     
C     Prints hemispheres separately, both right handed.                    XSECT.9     
C     Certain values of IOUT have special functions:                       XSECT.10    
C        IOUT=2 : Temporarily subtract 300K from potential temp.           XSECT.11    
C                 Also supresses >NCNT contour warning.                    XSECT.12    
C        IOUT=3 : Temporarily subtract 273.15K from temperature.           XSECT.13    
C        IOUT=18: Only 11 contours for total permitted wavenumber.         XSECT.14    
C                 Also supresses >NCNT contour warning.                    XSECT.15    
C     To avoid all of these for added fields use e.g. IOUT=0.              XSECT.16    
C                                                                          XSECT.17    
*CALL PARAM1                                                               XSECT.18    
*CALL PARAM2                                                               XSECT.19    
      PARAMETER(NCNT=50)                                                   XSECT.20    
C                                                                          XSECT.21    
*CALL BATS                                                                 XSECT.22    
*CALL COMMSK                                                               XSECT.23    
*CALL OUTCON                                                               XSECT.24    
      REAL F(JGG,NLOUT),CL(NCNT)                                           XSECT.25    
      LOGICAL LPRINT,LPLOT,LDUMP,LNPLT                                     XSECT.26    
      CHARACTER NAME*45,HEMANN(2)*30,DIMANN(4)*5                           XSECT.27    
      SAVE HEMANN,DIMANN                                                   XSECT.28    
C                                                                          XSECT.29    
      DATA HEMANN/'EQUATOR.............NORTH POLE'                         XSECT.30    
     :           ,'SOUTH POLE.............EQUATOR'/                        XSECT.31    
      DATA DIMANN/'     ','SIGMA','PRESS','THETA'/                         XSECT.32    
C                                                                          XSECT.33    
 6000 FORMAT(/1X,A,1PE10.3,A)                                              XSECT.34    
 6001 FORMAT(/1X,A,F10.1,A)                                                XSECT.35    
 6002 FORMAT(/1X,A,F10.3,A)                                                XSECT.36    
 6010 FORMAT(6X,'MIN  MAX  =',1P,2(2X,E10.3),A)                            XSECT.37    
 6020 FORMAT(' ZONAL MEAN',9X,15X,A)                                       XSECT.38    
 6030 FORMAT(' ZONAL MEAN ON ',A,15X,A)                                    XSECT.39    
 6040 FORMAT(1X,32I4)                                                      XSECT.40    
C                                                                          XSECT.41    
C     Set switches.                                                        XSECT.42    
C                                                                          XSECT.43    
      IPTYP=11                                                             XSECT.44    
      IMSK=0                                                               XSECT.45    
      IF (LMSK3.AND.(LPLOT.OR.LDUMP).AND.LNPLT.AND.(IZDIM.EQ.2)) IMSK=1    XSECT.46    
C                                                                          XSECT.47    
C     Temporarily remove offset for temperature fields.                    XSECT.48    
C                                                                          XSECT.49    
      IF (IOUT.EQ.2.OR.IOUT.EQ.3) THEN                                     XSECT.50    
         IF (IOUT.EQ.2) XOF=300.                                           XSECT.51    
         IF (IOUT.EQ.3) XOF=273.15                                         XSECT.52    
         DO 10 L=1,NLOUT                                                   XSECT.53    
         DO 10 J=1,JGG                                                     XSECT.54    
   10    F(J,L)=F(J,L)-XOF                                                 XSECT.55    
      ENDIF                                                                XSECT.56    
C                                                                          XSECT.57    
C     Set up printing factor, contour levels etc.                          XSECT.58    
C                                                                          XSECT.59    
      MCNT=NCNT                                                            XSECT.60    
      IF (IOUT.EQ.18) MCNT=11                                              XSECT.61    
      CALL GPREP(F,JGG*NLOUT,AFAC,CINC,CL,MCNT,GNORM,GINC,ICNT             XSECT.62    
     :          ,GMIN,GMAX,IFAIL)                                          XSECT.63    
      IF (.NOT.((IOUT.EQ.2.OR.IOUT.EQ.18).AND.IFAIL.EQ.2)) THEN            XSECT.64    
         IF (IFAIL.NE.0) CALL GFAIL(IFAIL,LPRINT,LPLOT,LDUMP               XSECT.65    
     :                             ,NAME(1:30),ICNT)                       XSECT.66    
      ENDIF                                                                XSECT.67    
C                                                                          XSECT.68    
C     Print field.                                                         XSECT.69    
C                                                                          XSECT.70    
      IF (LPRINT) THEN                                                     XSECT.71    
         ZUNIT=1./GNORM                                                    XSECT.72    
         IF (ZUNIT.GT.1000..OR.ZUNIT.LE..099) THEN                         XSECT.73    
            WRITE(NPC,6000) NAME(1:30),ZUNIT,NAME(31:45)                   XSECT.74    
         ELSE IF (ZUNIT.GE.10.) THEN                                       XSECT.75    
            WRITE(NPC,6001) NAME(1:30),ZUNIT,NAME(31:45)                   XSECT.76    
         ELSE                                                              XSECT.77    
            WRITE(NPC,6002) NAME(1:30),ZUNIT,NAME(31:45)                   XSECT.78    
         ENDIF                                                             XSECT.79    
         WRITE(NPC,6010) GMIN,GMAX,NAME(31:45)                             XSECT.80    
         DO 40 IHEM=1,NHEM                                                 XSECT.81    
         IF (IZDIM.EQ.0) THEN                                              XSECT.82    
            WRITE(NPC,6020) HEMANN(IHEM)                                   XSECT.83    
         ELSE                                                              XSECT.84    
            WRITE(NPC,6030) DIMANN(IZDIM+1),HEMANN(IHEM)                   XSECT.85    
         ENDIF                                                             XSECT.86    
         NPOLE=1+(NLAT-1)*INLAT                                            XSECT.87    
         IF (IHEM.EQ.1) THEN                                               XSECT.88    
            DO 20 L=1,NLOUT                                                XSECT.89    
   20       WRITE(NPC,6040) (NINT(F(J,L)*GNORM),J=NPOLE,1,-INLAT)          XSECT.90    
         ELSE                                                              XSECT.91    
            DO 30 L=1,NLOUT                                                XSECT.92    
   30       WRITE(NPC,6040) (NINT(F(J,L)*GNORM),J=JGG,JGP,-INLAT)          XSECT.93    
         ENDIF                                                             XSECT.94    
   40    CONTINUE                                                          XSECT.95    
      ENDIF                                                                XSECT.96    
C                                                                          XSECT.97    
C     Only plot or dump field if data is on NL model or isobaric levels.   XSECT.98    
C                                                                          XSECT.99    
      IF (NLOUT.NE.NL) RETURN                                              XSECT.100   
C                                                                          XSECT.101   
C     Dump field to data transfer file.                                    XSECT.102   
C                                                                          XSECT.103   
      IF (LDUMP) THEN                                                      XSECT.104   
         ILVTYP=2                                                          XSECT.105   
         IF (IZDIM.EQ.1) ILVTYP=0                                          XSECT.106   
         IFRAME=0                                                          XSECT.107   
         IF (LNPLT) IFRAME=1                                               XSECT.108   
         CALL WTFUTF(F,JGG,NL,IPTYP,ICSTYL,0,ILVTYP,IFRAME,IMSK            XSECT.109   
     :              ,GMIN,GMAX,GINC,DAY,NAME,45,NPCA,IFAIL)                XSECT.110   
      ENDIF                                                                XSECT.111   
C                                                                          XSECT.112   
C     Add back the temporarily removed offset.                             XSECT.117   
C                                                                          XSECT.118   
      IF (IOUT.EQ.2.OR.IOUT.EQ.3) THEN                                     XSECT.119   
         DO 50 L=1,NL                                                      XSECT.120   
         DO 50 J=1,JGG                                                     XSECT.121   
   50    F(J,L)=F(J,L)+XOF                                                 XSECT.122   
      ENDIF                                                                XSECT.123   
C                                                                          XSECT.124   
      RETURN                                                               XSECT.125   
      END                                                                  XSECT.126   
C     ****************************************************************     XSECT.127   
*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 COMUTF                                                               INIUTF.9     
*CALL BATS                                                                 INIUTF.10    
*CALL BLANK                                                                INIUTF.11    
*CALL OUTCON                                                               INIUTF.12    
      REAL ALOND(MG),ASIG(NL)                                              INIUTF.13    
      CHARACTER*8 NAME(2)                                                  SUNMOD.77    
C                                                                          INIUTF.15    
 6900 FORMAT(/' ***ABORT IN INIUTF : ASCARR ARRAY SIZE MUST BE'            INIUTF.16    
     :       ,' INCREASED FROM',I5,' TO',I5)                               INIUTF.17    
 6910 FORMAT(/' ***INIUTF : ASCARR ARRAY SIZE CAN BE'                      INIUTF.18    
     :       ,' REDUCED FROM',I5,' TO',I5,' AT THIS RESOLUTION')           INIUTF.19    
C                                                                          INIUTF.20    
C     Check size of character data array ASCARR.                           INIUTF.21    
C                                                                          INIUTF.22    
      IMLEN=MAX0(IDH,IGG)                                                  INIUTF.23    
      IF (IMLEN.GT.IALEN) THEN                                             INIUTF.24    
         WRITE(6,6900) IALEN,IMLEN                                         INIUTF.25    
         CALL ABORT                                                        INIUTF.26    
      ELSE IF (IMLEN.LT.IALEN) THEN                                        INIUTF.27    
         WRITE(6,6910) IALEN,IMLEN                                         INIUTF.28    
      ENDIF                                                                INIUTF.29    
C                                                                          INIUTF.30    
C     Set up data for global header.                                       INIUTF.31    
C                                                                          INIUTF.32    
      LHDR='***START OF HEADER***'                                         INIUTF.33    
      LDAT='***START OF DATA***  '                                         INIUTF.34    
      LEND='***END OF DATA***    '                                         INIUTF.35    
      LVER='***UTF 1.3***        '                                         INIUTF.36    
C                                                                          INIUTF.37    
      DO 10 I=1,15                                                         INIUTF.38    
   10 IHR1(I)=0                                                            INIUTF.39    
      IHR1(1)=MG                                                           INIUTF.40    
      IHR1(2)=JG                                                           INIUTF.41    
      IHR1(3)=NL                                                           INIUTF.42    
      IHR1(4)=NHEM                                                         INIUTF.43    
      IHR1(5)=MOCT                                                         INIUTF.44    
      IHR1(8)=MM                                                           INIUTF.45    
      IHR1(9)=NN                                                           INIUTF.46    
      IHR1(10)=NWJ2                                                        INIUTF.47    
C                                                                          INIUTF.48    
      DALON=360./FLOAT(MG*MOCT)                                            INIUTF.49    
      DO 20 I=1,MG                                                         INIUTF.50    
   20 ALOND(I)=FLOAT(I-1)*DALON                                            INIUTF.51    
C                                                                          INIUTF.52    
      DO 30 L=1,NL                                                         INIUTF.53    
   30 ASIG(L)=1000.*SIGMA(L)                                               INIUTF.54    
C                                                                          INIUTF.55    
      BEGDAY=FLOAT(KSTART)/TSPD                                            INIUTF.56    
      ENDDAY=FLOAT(KEND)/TSPD                                              INIUTF.57    
C                                                                          INIUTF.58    
C     Write global header.                                                 INIUTF.59    
C                                                                          INIUTF.60    
      WRITE(NCHAN,'(2(A21,4X),''.'')') LHDR,LVER                           INIUTF.61    
      WRITE(NCHAN,'(15I5)') (IHR1(I),I=1,15)                               INIUTF.62    
      WRITE(NCHAN,'((10F7.2))') (ALOND(I),I=1,MG)                          INIUTF.63    
      WRITE(NCHAN,'((10F7.2))') (ALAT(J),J=1,JGG)                          INIUTF.64    
      IF (NL.LE.19) THEN                                                   EUTF1.1     
         WRITE(NCHAN,'((10F7.1))') (ASIG(L),L=1,NL)                        EUTF1.2     
      ELSE IF (NL.GT.19) THEN                                              EUTF1.3     
         WRITE(NCHAN,'(1P,5(1X,E12.5))') (ASIG(L),L=1,NL)                  EUTF1.4     
      ENDIF                                                                EUTF1.5     
      WRITE(LHT1,'(''RUN '',F8.3,5X,''DAYS '',F10.2,'' TO'',F10.2,5X)')    INIUTF.66    
     :      RNTAPE,BEGDAY,ENDDAY                                           INIUTF.67    
      WRITE(NCHAN,'(A50,''.'')') LHT1                                      INIUTF.68    
      WRITE(LHT2,'(2A8,34X)') (NAME(I),I=1,2)                              INIUTF.69    
      WRITE(NCHAN,'(A50,''.'')') LHT2                                      INIUTF.70    
      WRITE(NCHAN,'(2(A21,4X),''.'')') LDAT,LVER                           INIUTF.71    
C                                                                          INIUTF.72    
C     Initialise field header arrays.                                      INIUTF.73    
C                                                                          INIUTF.74    
      WRITE(LFT1,'(50X)')                                                  INIUTF.75    
      WRITE(LFT2D,'(''RUN '',F8.3,3X,''DAY'',32X)') RNTAPE                 INIUTF.76    
      WRITE(LFT2T,'(''RUN '',F8.3,3X,''DAY'',F10.2,'' TO'',F10.2           INIUTF.77    
     :              ,'' AVERAGE '')') RNTAPE,BEGDAY,ENDDAY                 INIUTF.78    
      DO 40 I=1,15                                                         INIUTF.79    
   40 IFR3(I)=0                                                            INIUTF.80    
C                                                                          INIUTF.81    
C     Initialise character look-up table for ASCOUT.                       INIUTF.82    
C                                                                          INIUTF.83    
      CALL ASCSET                                                          INIUTF.84    
C                                                                          INIUTF.85    
      RETURN                                                               INIUTF.86    
      END                                                                  INIUTF.87    
C     ****************************************************************     INIUTF.88    
*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 COMUTF                                                               ENDUTF.7     
      WRITE(NCHAN,'(2(A21,4X),''.'')') LEND,LVER                           ENDUTF.8     
C                                                                          ENDUTF.9     
      RETURN                                                               ENDUTF.10    
      END                                                                  ENDUTF.11    
C     ****************************************************************     ENDUTF.12    
*DECK WTFUTF                                                               WTFUTF.1     
      SUBROUTINE WTFUTF(G,IX,IY,IPTYP,ICSTYL,IFDTYP,ILVTYP,IFRAME,IMSK     WTFUTF.2     
     :                 ,FMIN,FMAX,GINC,DAY,NAME,NCHAR,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 COMUTF                                                               WTFUTF.8     
      REAL G(IX*IY)                                                        WTFUTF.9     
      CHARACTER NAME*(*)                                                   WTFUTF.10    
C                                                                          WTFUTF.11    
 6900 FORMAT(/' ***WTFUTF : ',A,' NOT DUMPED : LENGTH OF ASCARR'           WTFUTF.12    
     :       ,' (IALEN) MUST BE INCREASED FROM',I5,' TO',I5)               WTFUTF.13    
 6910 FORMAT(/' ***WTFUTF : WARNING : ',A,' HAS ZERO RANGE')               WTFUTF.14    
C                                                                          WTFUTF.15    
C     Check size of data array.                                            WTFUTF.16    
C                                                                          WTFUTF.17    
      NXY=IX*IY                                                            WTFUTF.18    
      IF (NXY.GT.IALEN) THEN                                               WTFUTF.19    
         WRITE(6,6900) NAME,IALEN,NXY                                      WTFUTF.20    
         IFAIL=1                                                           WTFUTF.21    
         RETURN                                                            WTFUTF.22    
      ENDIF                                                                WTFUTF.23    
C                                                                          WTFUTF.24    
C     Calculate minimum and maximum values of field if input values        WTFUTF.25    
C     are zero.                                                            WTFUTF.26    
C                                                                          WTFUTF.27    
      IF (FMIN.EQ.0..AND.FMAX.EQ.0.) THEN                                  WTFUTF.28    
         MX=ISMAX(NXY,G,1)                                                 WTFUTF.29    
         GMAX=G(MX)                                                        WTFUTF.30    
         MN=ISMIN(NXY,G,1)                                                 WTFUTF.31    
         GMIN=G(MN)                                                        WTFUTF.32    
      ELSE                                                                 WTFUTF.33    
         GMIN=FMIN                                                         WTFUTF.34    
         GMAX=FMAX                                                         WTFUTF.35    
      ENDIF                                                                WTFUTF.36    
C                                                                          WTFUTF.37    
C     Check range of field.                                                WTFUTF.38    
C                                                                          WTFUTF.39    
      RANGE=GMAX-GMIN                                                      WTFUTF.40    
      GAMAX=MAX(ABS(GMIN),ABS(GMAX))                                       SUNMOD.96    
      IF (RANGE.LE.GAMAX*1.E-10) THEN                                      WTFUTF.42    
         WRITE(6,6910) NAME                                                WTFUTF.43    
         IFAIL=2                                                           WTFUTF.44    
      ENDIF                                                                WTFUTF.45    
C                                                                          WTFUTF.46    
C     Set up integer switch record.                                        WTFUTF.47    
C                                                                          WTFUTF.48    
      IFR3(1)=IX                                                           WTFUTF.49    
      IFR3(2)=IY                                                           WTFUTF.50    
      IFR3(3)=IPTYP                                                        WTFUTF.51    
      IFR3(4)=ICSTYL                                                       WTFUTF.52    
      IFR3(5)=IFDTYP                                                       WTFUTF.53    
      IFR3(6)=ILVTYP                                                       WTFUTF.54    
      IFR3(7)=IFRAME                                                       WTFUTF.55    
      IFR3(9)=IMSK                                                         WTFUTF.56    
C                                                                          WTFUTF.57    
C     Set up field title.                                                  WTFUTF.58    
C                                                                          WTFUTF.59    
      WRITE(LFT1,'(50X)')                                                  WTFUTF.60    
      INCHAR=MIN0(50,NCHAR)                                                WTFUTF.61    
      WRITE(LFT1(1:INCHAR),'(A)') NAME(1:INCHAR)                           WTFUTF.62    
C                                                                          WTFUTF.63    
C     Write field header.                                                  WTFUTF.64    
C                                                                          WTFUTF.65    
      WRITE(NCHAN,'(A50,''.'')') LFT1                                      WTFUTF.66    
      IF (DAY.GE.0) THEN                                                   WTFUTF.67    
         WRITE(LFT2D(19:28),'(F10.2)') DAY                                 WTFUTF.68    
         WRITE(NCHAN,'(A50,''.'')') LFT2D                                  WTFUTF.69    
      ELSE                                                                 WTFUTF.70    
         WRITE(NCHAN,'(A50,''.'')') LFT2T                                  WTFUTF.71    
      ENDIF                                                                WTFUTF.72    
      WRITE(NCHAN,'(15I5)') (IFR3(I),I=1,15)                               WTFUTF.73    
      WRITE(NCHAN,'(1P,3E15.7)') GMIN,GMAX,GINC                            WTFUTF.74    
C                                                                          WTFUTF.75    
C     Pack and write data.                                                 WTFUTF.76    
C                                                                          WTFUTF.77    
      CALL ASCOUT(G,NXY,ASCARR,GMIN,GMAX,NCHAN)                            WTFUTF.78    
      IFAIL=0                                                              WTFUTF.79    
C                                                                          WTFUTF.80    
      RETURN                                                               WTFUTF.81    
      END                                                                  WTFUTF.82    
C     ****************************************************************     WTFUTF.83    
*DECK ASCOUT                                                               ASCOUT.1     
      SUBROUTINE ASCOUT(ARRAY,NPTS,ASCARR,GMIN,GMAX,NCHAN)                 ASCOUT.2     
C                                                                          ASCOUT.3     
C     Pack and write a data array as a set of pairs of characters.         ASCOUT.4     
C     Uses the characters 0-9 and lower and upper case A-Z only.           ASCOUT.5     
C                                                                          ASCOUT.6     
C     Input arguments:                                                     ASCOUT.7     
C        ARRAY   -    Real data array.                                     ASCOUT.8     
C        NPTS    -    Dimension of array.                                  ASCOUT.9     
C        ASCARR  -    A CHARACTER*1 workspace array of length 2*NPTS.      ASCOUT.10    
C        GMIN    -    Minimum value of array.                              ASCOUT.11    
C        GMAX    -    Maximum value of array.                              ASCOUT.12    
C        NCHAN   -    Fortran channel for data output.                     ASCOUT.13    
C     Arguments unchanged on output except ASCARR contains characters.     ASCOUT.14    
C                                                                          ASCOUT.15    
C     Kevin Dunn / Mike Blackburn     U.G.A.M.P.   03.01.89.               ASCOUT.16    
C     Based on code by M. A. Rowe       (FRAM)        09.87.               ASCOUT.17    
C                                                                          ASCOUT.18    
      REAL ARRAY(NPTS)                                                     ASCOUT.19    
      CHARACTER*1  ASCARR(2,NPTS), LKUP(63)                                ASCOUT.20    
      LOGICAL LASCII                                                       ASCOUT.21    
      SAVE LKUP                                                            ASCOUT.22    
C                                                                          ASCOUT.23    
C     Find scaling factor. Set to unity for zero field range.              ASCOUT.24    
C                                                                          ASCOUT.25    
      GAMAX=MAX(ABS(GMAX),ABS(GMIN))                                       SUNMOD.97    
      RANGE=GMAX-GMIN                                                      ASCOUT.27    
      ARANG=62.*62.-1.                                                     ASCOUT.28    
      IF (RANGE.LE.GAMAX*1.E-10) THEN                                      ASCOUT.29    
         SCALE=0.                                                          ASCOUT.30    
      ELSE                                                                 ASCOUT.31    
         SCALE=ARANG/RANGE                                                 ASCOUT.32    
      ENDIF                                                                ASCOUT.33    
C                                                                          ASCOUT.34    
C     Scale data using range of field and encode each value                ASCOUT.35    
C     using subscript of look-up table character.                          ASCOUT.36    
C                                                                          ASCOUT.37    
      DO 10 N=1,NPTS                                                       ASCOUT.38    
      INTEG=NINT((ARRAY(N)-GMIN)*SCALE)                                    ASCOUT.39    
      ICODE1=1+INTEG/62                                                    ASCOUT.40    
      ICODE2=1+MOD(INTEG,62)                                               ASCOUT.41    
      ASCARR(1,N)=LKUP(ICODE1)                                             ASCOUT.42    
      ASCARR(2,N)=LKUP(ICODE2)                                             ASCOUT.43    
   10 CONTINUE                                                             ASCOUT.44    
C                                                                          ASCOUT.45    
C     Write encoded data.                                                  ASCOUT.46    
C                                                                          ASCOUT.47    
      WRITE(NCHAN,'(64A1)') ((ASCARR(I,N),I=1,2),N=1,NPTS)                 ASCOUT.48    
C                                                                          ASCOUT.49    
      RETURN                                                               ASCOUT.50    
C                                                                          ASCOUT.51    
C     ----------------------------------------------------------------     ASCOUT.52    
      ENTRY ASCSET                                                         ASCOUT.53    
C                                                                          ASCOUT.54    
C     Define look-up table of characters.                                  ASCOUT.55    
C     Table includes 0-9 and lower and upper case characters A-Z           ASCOUT.56    
C     but not control characters. ASCII or EBCDIC character sets           ASCOUT.57    
C     are allowed and test made to determine current set.                  ASCOUT.58    
C     Characters 1-62 in LKUP are used to represent integer values         ASCOUT.59    
C     1-62. The range of the data field is scaled to 62*62 and two         ASCOUT.60    
C     characters used to represent each datum (2 digits in base 62).       ASCOUT.61    
C     63rd character in LKUP is blank for possible future masking.         ASCOUT.62    
C                                                                          ASCOUT.63    
      LASCII=ICHAR('0').NE.240                                             ASCOUT.64    
      IF (LASCII) THEN                                                     ASCOUT.65    
C***  Implementation for ASCII characters.                                 ASCOUT.66    
      DO 21 I=1,10                                                         ASCOUT.67    
   21 LKUP(I)=CHAR(I+47)                                                   ASCOUT.68    
      DO 22 I=11,36                                                        ASCOUT.69    
   22 LKUP(I)=CHAR(I+54)                                                   ASCOUT.70    
      DO 23 I=37,62                                                        ASCOUT.71    
   23 LKUP(I)=CHAR(I+60)                                                   ASCOUT.72    
      LKUP(63)=CHAR(32)                                                    ASCOUT.73    
      ELSE                                                                 ASCOUT.74    
C***  Implementation for EBCDIC characters                                 ASCOUT.75    
      DO 31 I=1,10                                                         ASCOUT.76    
   31 LKUP(I)=CHAR(I+239)                                                  ASCOUT.77    
      DO 32 I=11,19                                                        ASCOUT.78    
   32 LKUP(I)=CHAR(I+182)                                                  ASCOUT.79    
      DO 33 I=20,28                                                        ASCOUT.80    
   33 LKUP(I)=CHAR(I+189)                                                  ASCOUT.81    
      DO 34 I=29,36                                                        ASCOUT.82    
   34 LKUP(I)=CHAR(I+197)                                                  ASCOUT.83    
      DO 35 I=37,45                                                        ASCOUT.84    
   35 LKUP(I)=CHAR(I+92)                                                   ASCOUT.85    
      DO 36 I=46,54                                                        ASCOUT.86    
   36 LKUP(I)=CHAR(I+99)                                                   ASCOUT.87    
      DO 37 I=55,62                                                        ASCOUT.88    
   37 LKUP(I)=CHAR(I+107)                                                  ASCOUT.89    
      LKUP(63)=CHAR(64)                                                    ASCOUT.90    
      END IF                                                               ASCOUT.91    
      RETURN                                                               ASCOUT.92    
C     ----------------------------------------------------------------     ASCOUT.93    
C                                                                          ASCOUT.94    
      END                                                                  ASCOUT.95    
C     ****************************************************************     ASCOUT.96    
